Giúp đỡ viết code copy transpose

[xuan_nam]

Tôi có file đính kèm, Muốn copy dữ liệu từ các file paste Transport sang file tổng hợp, tôi có code nhưng nó paste theo hàng dọc, mọi người có thể sửa code này cho nó dán theo hàng ngang được không ạ, xin chân thành cảm ơn!

 

[xuan_nam]

Tôi có file đính kèm, Muốn copy dữ liệu từ các file paste Transport sang file tổng hợp, tôi có code nhưng nó paste theo hàng dọc, mọi người có thể sửa code này cho nó dán theo hàng ngang được không ạ, xin chân thành cảm ơn!

Sub Button1_Click()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim n As Long, rNum As Long
Dim MyPath As String
Dim SaveDriveDir As String
Dim FName As Variant
SaveDriveDir = CurDir
MyPath = "D:\TXT\"
ChDrive MyPath
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xls*), *.xls*", MultiSelect:=True)
If IsArray(FName) Then
Set basebook = ActiveWorkbook
rNum = 1
'Xoa du lieu cu
Sheets("THCS").Range("b9:b38").ClearContents
Sheets("THCS").Range("d9:f38").ClearContents
Sheets("THCS").Range("h9:k38").ClearContents
For n = LBound(FName) To UBound(FName)
Set mybook = Workbooks.Open(FName(n))
'Tong hop TH Lop,HS,CBGVNv
Set sourceRange = mybook.Worksheets("Truong").Range("d4")
rNum = (n - 1) * sourceRange.Rows.Count + 9
'Xac dinh o de copy
With sourceRange
Set destrange = basebook.Worksheets("THCS").Cells(rNum, "b").Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
'-----------
Set sourceRange = mybook.Worksheets("BCao nhanh").Range("f106:f108")
rNum = (n - 1) * sourceRange.Rows.Count + 9
'Xac dinh o de copy
With sourceRange
Set destrange = basebook.Worksheets("THCS").Cells(rNum, "d").Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
'--------------
Set sourceRange = mybook.Worksheets("BCao nhanh").Range("f111:f114")
rNum = (n - 1) * sourceRange.Rows.Count + 9
'Xac dinh o de copy
With sourceRange
Set destrange = basebook.Worksheets("THCS").Cells(rNum, "h").Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
mybook.Close False
Next n
End If
'Tra ve mac dinh truoc khi mo
ChDrive SaveDriveDir
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Mong các Pro chỉnh code này cho nó dán theo hàng ngang với ạ

 

[xuan_nam]

Xin các cao nhân chỉ giúp tôi tí ạ. Xin cảm ơn mọi người trước.

 

[hhoang_56]

Chả hiểu "Pro" là gì

 

[HeSanbi]

Bạn muốn sao thì làm vậy, chứ hỏi thêm là tôi "chịu"

Transpose của bạn nằm ở đoạn:

nRNG(1, 1).Resize(nRNG.Columns.Count, nRNG.Rows.Count).Value = Application.Transpose(sRNG.Value)

Những cách chọn file như thế này thì bạn nên tham khảo thêm các hàm lấy đường dẫn file và folder do tôi viết tại đây

-----------------

Sub Button1_Click()
  Dim WB As Workbook, nWB As Workbook
  Dim THCS As Worksheet
  Dim sRNG As Range, nRNG As Range
  Dim n As Long, rNum As Long
  Dim MyPath As String, sC$
  Dim FName
  SaveDriveDir = CurDir
  MyPath = ThisWorkbook.Path
  ChDrive MyPath
  With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
  End With
  FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xls*), *.xls*", MultiSelect:=True)
  If Not IsArray(FName) Then Exit Sub
  Set WB = ThisWorkbook
  Set THCS = WB.Worksheets("THCS")
  rNum = 1
  THCS.Range("b9:b38").ClearContents
  THCS.Range("d9:f38").ClearContents
  THCS.Range("h9:k38").ClearContents
  For n = LBound(FName) To UBound(FName)
      Set nWB = Workbooks.Open(FName(n))
      Set sRNG = nWB.Worksheets("Truong").Range("d4")
      rNum = (n - 1) * sRNG.Rows.Count + 9
      sC = "b": GoSub GetRow
      Set sRNG = nWB.Worksheets("BCao nhanh").Range("f106:f108")
      rNum = (n - 1) * sRNG.Rows.Count + 9
      sC = "d": GoSub GetRow
      Set sRNG = nWB.Worksheets("BCao nhanh").Range("f111:f114")
      rNum = (n - 1) * sRNG.Rows.Count + 9
      sC = "h": GoSub GetRow
      nWB.Close False
  Next n
  ChDrive SaveDriveDir
  With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
  End With

  Exit Sub
GetRow:
  Set nRNG = THCS.Cells(rNum, sC).Resize(sRNG.Rows.Count, sRNG.Columns.Count)
  nRNG(1, 1).Resize(nRNG.Columns.Count, nRNG.Rows.Count).Value = Application.Transpose(sRNG.Value)
Return
End Sub

 

[xuan_nam]

Bạn muốn sao thì làm vậy, chứ hỏi thêm là tôi "chịu"

Transpose của bạn nằm ở đoạn:

nRNG(1, 1).Resize(nRNG.Columns.Count, nRNG.Rows.Count).Value = Application.Transpose(sRNG.Value)

Những cách chọn file như thế này thì bạn nên tham khảo thêm các hàm lấy đường dẫn file và folder do tôi viết tại đây

-----------------

Sub Button1_Click()
  Dim WB As Workbook, nWB As Workbook
  Dim THCS As Worksheet
  Dim sRNG As Range, nRNG As Range
  Dim n As Long, rNum As Long
  Dim MyPath As String, sC$
  Dim FName
  SaveDriveDir = CurDir
  MyPath = ThisWorkbook.Path
  ChDrive MyPath
  With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
  End With
  FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xls*), *.xls*", MultiSelect:=True)
  If Not IsArray(FName) Then Exit Sub
  Set WB = ThisWorkbook
  Set THCS = WB.Worksheets("THCS")
  rNum = 1
  THCS.Range("b9:b38").ClearContents
  THCS.Range("d9:f38").ClearContents
  THCS.Range("h9:k38").ClearContents
  For n = LBound(FName) To UBound(FName)
      Set nWB = Workbooks.Open(FName(n))
      Set sRNG = nWB.Worksheets("Truong").Range("d4")
      rNum = (n - 1) * sRNG.Rows.Count + 9
      sC = "b": GoSub GetRow
      Set sRNG = nWB.Worksheets("BCao nhanh").Range("f106:f108")
      rNum = (n - 1) * sRNG.Rows.Count + 9
      sC = "d": GoSub GetRow
      Set sRNG = nWB.Worksheets("BCao nhanh").Range("f111:f114")
      rNum = (n - 1) * sRNG.Rows.Count + 9
      sC = "h": GoSub GetRow
      nWB.Close False
  Next n
  ChDrive SaveDriveDir
  With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
  End With

  Exit Sub
GetRow:
  Set nRNG = THCS.Cells(rNum, sC).Resize(sRNG.Rows.Count, sRNG.Columns.Count)
  nRNG(1, 1).Resize(nRNG.Columns.Count, nRNG.Rows.Count).Value = Application.Transpose(sRNG.Value)
Return
End Sub

Khi chạy các hàng sau không cùng với tên trường nó vẫn trừ ra các dòng trống, bạn có thế xem lại không.

 

[HeSanbi]

Khi chạy các hàng sau không cùng với tên trường nó vẫn trừ ra các dòng trống, bạn có thế xem lại không.

Bạn muốn transpose thì tôi sửa thành transpose thôi chứ tôi có sửa code chỗ nào nữa đâu, không trùng là do code của bạn từ đầu, thì phải viết lại từ đầu, nhưng tính tôi có khi "lười" đột xuất nên không giúp bạn được.