Giúp code nối dữ liệu từ nhiều sheet vào 1 sheet TongHop! (1 người xem)

  • Thread starter Thread starter LienDong
  • Ngày gửi Ngày gửi
Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
L

LienDong

Thành viên thường trực
Tham gia
22/11/12
Bài viết
233
Được thích
46
Nghề nghiệp
Ai nói đúng thì làm!
Chào các bạn
Các bạn viết giùm code nối dữ liệu từ nhiều sheet vào 1 sheet TongHop, cụ thể như sau:
Copy các cột A và B, bắt đầu từ ô A3 cho đến hết dòng dữ liệu rồi Paste qua Sheet Tonghop tại ô bắt đầu là F10
Sheet ư tiên copy trước là Lop1A rồi đến Lop2B cuối cùng là Lop3C
Vì dữ liệu thay đổi liên tục nên mình muốn một nút cập nhật, khi nào cần cập nhật thì mình bấm nút
Cảm ơn cả nhà!
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Chắc bạn cũng biết về Code vậy bạn thử Code này xem
Mã: 
Sub GhepLop()
Dim Ws As Worksheet, Arr


Sheets("TongHop").[F10:H65536].ClearContents
For Each Ws In ThisWorkbook.Worksheets
    If Ws.Name <> "TongHop" Then
        Arr = Ws.Range("A3:C" & Ws.Range("A65536").End(3).Row)
        Sheets("TongHop").[f65536].End(3).Offset(1, 0).Resize(UBound(Arr), 3) = Arr
    End If
Next
End Sub
 
Upvote 0
LienDong đã viết:
Chào các bạn
Các bạn viết giùm code nối dữ liệu từ nhiều sheet vào 1 sheet TongHop, cụ thể như sau:
Copy các cột A và B, bắt đầu từ ô A3 cho đến hết dòng dữ liệu rồi Paste qua Sheet Tonghop tại ô bắt đầu là F10
Sheet ư tiên copy trước là Lop1A rồi đến Lop2B cuối cùng là Lop3C
Vì dữ liệu thay đổi liên tục nên mình muốn một nút cập nhật, khi nào cần cập nhật thì mình bấm nút
Cảm ơn cả nhà!
Nhấp chuột vào đây để mở rộng...

Thử thêm cách này.
Bạn có thể sửa dòng này để có thứ tự copy theo ý muốn
ShName = Array("Lop1A", "Lop2B", "Lop3C")
PHP: 
Sub Lop_copy()
Dim Arr(), ShName(), i As Byte
ShName = Array("Lop1A", "Lop2B", "Lop3C")
Sheets("TongHop").[F10:H65536].ClearContents
   For i = 0 To UBound(ShName)
      With Sheets(ShName(i))
         If .Name <> "TongHop" Then
             Arr = .Range(.[A3], .[C65536].End(3)).Value
             Sheets("TongHop").[F65536].End(3).Offset(1).Resize(UBound(Arr), 3) = Arr
         End If
       End With
   Next i
End Sub
 
Upvote 0
Cảm ơn các bạn đã giúp đỡ
Code của bạn dhn46, nếu trong file có` bao nhiêu sheet thì nó lấy hết và nó lấy thứ tự sheet từ trái qua! cái này mình cũng có cái dùng đến.
 
Upvote 0
quanghai1969 đã viết:
Thử thêm cách này.
Bạn có thể sửa dòng này để có thứ tự copy theo ý muốn
ShName = Array("Lop1A", "Lop2B", "Lop3C")
PHP: 
Sub Lop_copy()
Dim Arr(), ShName(), i As Byte
ShName = Array("Lop1A", "Lop2B", "Lop3C")
Sheets("TongHop").[F10:H65536].ClearContents
   For i = 0 To UBound(ShName)
      With Sheets(ShName(i))
         If .Name <> "TongHop" Then
             Arr = .Range(.[A3], .[C65536].End(3)).Value
             Sheets("TongHop").[F65536].End(3).Offset(1).Resize(UBound(Arr), 3) = Arr
         End If
       End With
   Next i
End Sub
Nhấp chuột vào đây để mở rộng...
Mình nhờ Bạn Quanghai1969 và các bạn giúp mình thay đổi code 1 tí như sau:
Cột F của Sheet TH sẽ lấy cột A của các Sheet kia
Cột G của Sheet TH sẽ lấy cột E của các Sheet kia
Các bạn xem trong File. Cảm ơn các bạn
 

File đính kèm

Upvote 0
LienDong đã viết:
Mình nhờ Bạn Quanghai1969 và các bạn giúp mình thay đổi code 1 tí như sau:
Cột F của Sheet TH sẽ lấy cột A của các Sheet kia
Cột G của Sheet TH sẽ lấy cột E của các Sheet kia
Các bạn xem trong File. Cảm ơn các bạn
Nhấp chuột vào đây để mở rộng...
Thêm tí xíu vài code cũ. Muốn code đẹp thì tự trao chuốt lại tí là được
PHP: 
Sub Lop_copy_QH()
Dim ArrA(), ShName(), i As Byte, ArrE()
ShName = Array("Lop1A", "Lop2B", "Lop3C")
With Sheets("TongHop")
   .[F10:G65536].ClearContents
   For i = 0 To UBound(ShName)
      With Sheets(ShName(i))
         If .Name <> "TongHop" Then
            ArrA = .Range(.[A3], .[A65536].End(3)).Value
            ArrE = .Range(.[E3], .[E65536].End(3)).Value
         End If
       End With
      .[F65536].End(3).Offset(1).Resize(UBound(ArrA)) = ArrA
      .[G65536].End(3).Offset(1).Resize(UBound(ArrE)) = ArrE
   Next i
End With
End Sub
Hoặc đơn giản hơn chút
PHP: 
Sub Lop_copy()
Dim ShName(), i As Byte
ShName = Array("Lop1A", "Lop2B", "Lop3C")
With Sheets("TongHop")
   .[F10:G65536].ClearContents
   For i = 0 To UBound(ShName)
      With Sheets(ShName(i))
         If .Name <> "TongHop" Then
            Union(.Range(.[A3], .[A65536].End(3)), .Range(.[E3], .[E65536].End(3))).Copy
         End If
       End With
      .[F65536].End(3).Offset(1).PasteSpecial 3
   Next i
End With
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
LienDong đã viết:
Mình nhờ Bạn Quanghai1969 và các bạn giúp mình thay đổi code 1 tí như sau:
Cột F của Sheet TH sẽ lấy cột A của các Sheet kia
Cột G của Sheet TH sẽ lấy cột E của các Sheet kia
Các bạn xem trong File. Cảm ơn các bạn
Nhấp chuột vào đây để mở rộng...

Mình thấy trong file của bạn , bạn cũng tùy biến code của pác Quanghải rồi mà , bạn thử code này xem sao

Mã: 
Sub Lop_copy_QH() ' code nay chinh xac
Dim Arr1(), Arr2(), ShName(), i As Byte
ShName = Array("Lop1A", "Lop2B", "Lop3C")
Sheets("TongHop").[F10:H65536].ClearContents
   For i = 0 To UBound(ShName)
      With Sheets(ShName(i))
         If .Name <> "TongHop" Then
             Arr1 = .Range(.[A3], .[A65536].End(3)).Value
             Arr2 = .Range(.[E3], .[E65536].End(3)).Value
             Sheets("TongHop").[F65536].End(3).Offset(1).Resize(UBound(Arr1), 1) = Arr1
             Sheets("TongHop").[G65536].End(3).Offset(1).Resize(UBound(Arr1), 1) = Arr2
         End If
       End With
   Next i
End Sub

xem file đính kèm
 
Upvote 0
Cảm ơn sự giúp đỡ các bạn!
Mình đã làm được, nhưng làm xong anh trưởng phòng yêu cầu mình fải tách File ra như sau (không hiểu vì sao ổng muốn vậy!):
1/ File TongHop chỉ có trang TH
2/ File ChiTiet thì có các trang "Lop1A", "Lop2B", "Lop3C"
Và yêu cầu mình sửa File, hic, mình không biết sửa làm sao? Các bạn giúp mình với
Hai File này , mình để trên cùng 1 thư mục, như vậy khi cập nhật File TongHop thì có cần mở File kia không?
Cảm phiền các bạn giúp đỡ thêm lần nữa, xin cảm ơn!
 
Upvote 0
LienDong đã viết:
Cảm ơn sự giúp đỡ các bạn!
Mình đã làm được, nhưng làm xong anh trưởng phòng yêu cầu mình fải tách File ra như sau (không hiểu vì sao ổng muốn vậy!):
1/ File TongHop chỉ có trang TH
2/ File ChiTiet thì có các trang "Lop1A", "Lop2B", "Lop3C"
Và yêu cầu mình sửa File, hic, mình không biết sửa làm sao? Các bạn giúp mình với
Hai File này , mình để trên cùng 1 thư mục, như vậy khi cập nhật File TongHop thì có cần mở File kia không?
Cảm phiền các bạn giúp đỡ thêm lần nữa, xin cảm ơn!
Nhấp chuột vào đây để mở rộng...
Tổng hợp nhiều sheet vào 1 sheet trong cùng 1 file hay tổng hợp nhiều sheet từ 1 file vào 1 file khác thì cách làm cũng như nhau thôi ---> Anh quanghai làm vụ này hoài
Ẹc.. ẹc..
-----------
Bài này dùng ADO là "bá chấy bù chét"
 
Upvote 0
ndu96081631 đã viết:
Tổng hợp nhiều sheet vào 1 sheet trong cùng 1 file hay tổng hợp nhiều sheet từ 1 file vào 1 file khác thì cách làm cũng như nhau thôi ---> Anh quanghai làm vụ này hoài
Nhấp chuột vào đây để mở rộng...
Đúng là em làm cái vụ này hoài nên cũng thấy quen quen tay
LienDong đã viết:
Cảm ơn sự giúp đỡ các bạn!
Mình đã làm được, nhưng làm xong anh trưởng phòng yêu cầu mình fải tách File ra như sau (không hiểu vì sao ổng muốn vậy!):
1/ File TongHop chỉ có trang TH
2/ File ChiTiet thì có các trang "Lop1A", "Lop2B", "Lop3C"
Và yêu cầu mình sửa File, hic, mình không biết sửa làm sao? Các bạn giúp mình với
Hai File này , mình để trên cùng 1 thư mục, như vậy khi cập nhật File TongHop thì có cần mở File kia không?
Cảm phiền các bạn giúp đỡ thêm lần nữa, xin cảm ơn!
Nhấp chuột vào đây để mở rộng...
Bạn thay code này vào là được, nếu không được thì mần tiếp. Code này mình chưa test vì không có file nhá. File CHITET.xls nha, nếu là .xlsx thì phải sửa code cho đúng nha
PHP: 
Sub Lop_copy()
Dim ShName(), i As Byte
ShName = Array("Lop1A", "Lop2B", "Lop3C")
Sheets("TongHop").[F10:G65536].ClearContents
   With Workbooks.Open(ThisWorkbook.Path & "\CHITIET.xls")
      For i = 0 To UBound(ShName)
         With .Sheets(ShName(i))
            Union(.Range(.[A3], .[A65536].End(3)), .Range(.[E3], .[E65536].End(3))).Copy
         End With
         ThisWorkbook.Sheets("TongHop").[F65536].End(3).Offset(1).PasteSpecial 3
      Next i
      Application.CutCopyMode = False
      .Close False
   End With
End Sub
Code này có bẫy lỗi nếu file CHITIET đang mở, nhưng chay code xong rồi file chitiet bị đóng luôn và không có lưu đấy nhá
PHP: 
Sub Lop_copy()
Dim ShName(), i As Byte, WB As Workbook, filedangmo As Boolean
ShName = Array("Lop1A", "Lop2B", "Lop3C")
Sheets("TongHop").[F10:G65536].ClearContents
For Each WB In Workbooks
   If WB.FullName = ThisWorkbook.Path & "\CHITIET.xls" Then filedangmo = True
Next
If filedangmo = False Then Workbooks.Open ThisWorkbook.Path & "\CHITIET.xls"
   With Workbooks("CHITIET.xls")
      For i = 0 To UBound(ShName)
         With .Sheets(ShName(i))
            Union(.Range(.[A3], .[A65536].End(3)), .Range(.[E3], .[E65536].End(3))).Copy
         End With
         ThisWorkbook.Sheets("TongHop").[F65536].End(3).Offset(1).PasteSpecial 3
      Next i
      Application.CutCopyMode = False
      .Close False
   End With
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
ndu96081631 đã viết:
Tổng hợp nhiều sheet vào 1 sheet trong cùng 1 file hay tổng hợp nhiều sheet từ 1 file vào 1 file khác thì cách làm cũng như nhau thôi ---> Anh quanghai làm vụ này hoài
Ẹc.. ẹc..
-----------
Bài này dùng ADO là "bá chấy bù chét"
Nhấp chuột vào đây để mở rộng...
Em không biết gì Về ADO anh à, !
 
Upvote 0
LienDong đã viết:
Em không biết gì Về ADO anh à, !
Nhấp chuột vào đây để mở rộng...

Thật ra bạn không biết cũng không sao, chỉ cần biết áp dụng khi người ta viết sẵn cho bạn đoạn code
Ví dụ tôi viết code ADO để lấy dữ liệu từ 1 file thế này:
Mã: 
Function GetData(ByVal FileName As String, ByVal SheetName As String, ByVal RangeAddress As String, _
            ByVal HasTitle As Boolean, ByVal UseTitle As Boolean)
            
  Dim rsCon As Object, rsData As Object, cat As Object, tbl As Object
  Dim tmpArr, Arr()
  Dim szConnect As String, szSQL As String
  Dim lCount As Long, lR As Long, lC As Long
  
  Set rsCon = CreateObject("ADODB.Connection")
  Set rsData = CreateObject("ADODB.Recordset")
  Set cat = CreateObject("ADOX.Catalog")
  
  If Val(Application.Version) < 12 Then
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FileName & ";" & _
                "Extended Properties=""Excel 8.0;HDR=" & IIf(HasTitle, "Yes", "No") & """;"
  Else
    szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";" & _
                "Extended Properties=""Excel 12.0;HDR=" & IIf(HasTitle, "Yes", "No") & """;"
  End If
  
  rsCon.Open szConnect
  cat.ActiveConnection = rsCon
  
  If SheetName = "" Then
    For Each tbl In cat.Tables
      If (Right(tbl.Name, 1) = "$") Or (Right(tbl.Name, 2) = "$'") Then
        SheetName = tbl.Name
        Exit For
      End If
    Next
  End If
  If Right(SheetName, 1) = "'" Then SheetName = Mid(SheetName, 2, Len(SheetName) - 2)
  If Right(SheetName, 1) <> "$" Then SheetName = SheetName & "$"
  szSQL = "SELECT * FROM [" & SheetName & RangeAddress & "];"
  rsData.Open szSQL, rsCon, 0, 1, 1
  tmpArr = rsData.GetRows
  ReDim Arr(UBound(tmpArr, 2) - UseTitle, UBound(tmpArr, 1) + 1)
  If UseTitle Then
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
      Arr(0, lC) = rsData.Fields(lC).Name
    Next
  End If
  For lR = LBound(tmpArr, 2) To UBound(tmpArr, 2)
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
      Arr(lR - UseTitle, lC) = tmpArr(lC, lR)
    Next
  Next
  rsData.Close: Set rsData = Nothing
  rsCon.Close: Set rsCon = Nothing
  GetData = Arr
End Function
Vậy bạn chỉ cần biết dùng cú pháp hàm là được
Mã: 
[B]GetData(Tên file cần lấy dữ liệu, Tên Sheet, Địa chỉ vùng dữ liệu, Dữ liệu có tiêu đề không?, Có lấy luôn tiêu đề không?)[/B]
Dựa vào cú pháp trên, ta viết thêm 1 Sub để gán vào nút nhấn:
Mã: 
Sub Main()
  Dim aWks(), aData
  Dim j As Long, t As Double
  Dim fleName As String, SheetName As String, sAddress As String, Target As Range
  t = Timer
  Application.ScreenUpdating = False
  aWks = Array("Lop1A", "Lop2B", "Lop3C") ''<---Tên các sheet ở file ChiTiet.xls
  sAddress = "A3:E1000" ''<--- Địa chỉ vùng dữ liệu cần lấy
  With ThisWorkbook
    fleName = .Path & "\Chitiet.xls" ''<--- Đường dẫn đến file ChiTiet.xls
    For j = 0 To UBound(aWks)
      SheetName = aWks(j)
      aData = GetData(fleName, SheetName, sAddress, False, False) ''<--- Lấy dữ liệu từ file Chitiet.xls và trả về kết quả là 1 mảng
      Set Target = .Sheets("TH").Range("F60000").End(xlUp).Offset(1) ''<--- Nơi đặt kết quả
      Target.Resize(UBound(aData, 1) + 1, UBound(aData, 2) + 1).Value = aData ''<--- Gán mảng xuống sheet
    Next
  End With
  Application.ScreenUpdating = True
  MsgBox "Done!", , Format(Timer - t, "0.000")
End Sub
Giờ chỉ cần nhấn nút và.. rung đùi thôi
--------------------------------
quanghai1969 đã viết:
Code này có bẫy lỗi nếu file CHITIET đang mở, nhưng chay code xong rồi file chitiet bị đóng luôn và không có lưu đấy nhá
Nhấp chuột vào đây để mở rộng...
Dùng ADO sẽ khỏi cần lo mấy vụ lẻ tẻ này
Ẹc... Ẹc...
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
ndu96081631 đã viết:
Thật ra bạn không biết cũng không sao, chỉ cần biết áp dụng khi người ta viết sẵn cho bạn đoạn code
Ví dụ tôi viết code ADO để lấy dữ liệu từ 1 file thế này:
Mã: 
Function GetData(ByVal FileName As String, ByVal SheetName As String, ByVal RangeAddress As String, _
            ByVal HasTitle As Boolean, ByVal UseTitle As Boolean)
            
  Dim rsCon As Object, rsData As Object, cat As Object, tbl As Object
  Dim tmpArr, Arr()
  Dim szConnect As String, szSQL As String
  Dim lCount As Long, lR As Long, lC As Long
  
  Set rsCon = CreateObject("ADODB.Connection")
  Set rsData = CreateObject("ADODB.Recordset")
  Set cat = CreateObject("ADOX.Catalog")
  
  If Val(Application.Version) < 12 Then
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FileName & ";" & _
                "Extended Properties=""Excel 8.0;HDR=" & IIf(HasTitle, "Yes", "No") & """;"
  Else
    szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";" & _
                "Extended Properties=""Excel 12.0;HDR=" & IIf(HasTitle, "Yes", "No") & """;"
  End If
  
  rsCon.Open szConnect
  cat.ActiveConnection = rsCon
  
  If SheetName = "" Then
    For Each tbl In cat.Tables
      If (Right(tbl.Name, 1) = "$") Or (Right(tbl.Name, 2) = "$'") Then
        SheetName = tbl.Name
        Exit For
      End If
    Next
  End If
  If Right(SheetName, 1) = "'" Then SheetName = Mid(SheetName, 2, Len(SheetName) - 2)
  If Right(SheetName, 1) <> "$" Then SheetName = SheetName & "$"
  szSQL = "SELECT * FROM [" & SheetName & RangeAddress & "];"
  rsData.Open szSQL, rsCon, 0, 1, 1
  tmpArr = rsData.GetRows
  ReDim Arr(UBound(tmpArr, 2) - UseTitle, UBound(tmpArr, 1) + 1)
  If UseTitle Then
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
      Arr(0, lC) = rsData.Fields(lC).Name
    Next
  End If
  For lR = LBound(tmpArr, 2) To UBound(tmpArr, 2)
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
      Arr(lR - UseTitle, lC) = tmpArr(lC, lR)
    Next
  Next
  rsData.Close: Set rsData = Nothing
  rsCon.Close: Set rsCon = Nothing
  GetData = Arr
End Function
Vậy bạn chỉ cần biết dùng cú pháp hàm là được
Mã: 
[B]GetData(Tên file cần lấy dữ liệu, Tên Sheet, Địa chỉ vùng dữ liệu, Dữ liệu có tiêu đề không?, Có lấy luôn tiêu đề không?)[/B]
Dựa vào cú pháp trên, ta viết thêm 1 Sub để gán vào nút nhấn:
Mã: 
Sub Main()
  Dim aWks(), aData
  Dim j As Long, t As Double
  Dim fleName As String, SheetName As String, sAddress As String, Target As Range
  t = Timer
  Application.ScreenUpdating = False
  aWks = Array("Lop1A", "Lop2B", "Lop3C") ''<---Tên các sheet ở file ChiTiet.xls
  sAddress = "A3:E1000" ''<--- Địa chỉ vùng dữ liệu cần lấy
  With ThisWorkbook
    fleName = .Path & "\Chitiet.xls" ''<--- Đường dẫn đến file ChiTiet.xls
    For j = 0 To UBound(aWks)
      SheetName = aWks(j)
      aData = GetData(fleName, SheetName, sAddress, False, False) ''<--- Lấy dữ liệu từ file Chitiet.xls và trả về kết quả là 1 mảng
      Set Target = .Sheets("TH").Range("F60000").End(xlUp).Offset(1) ''<--- Nơi đặt kết quả
      Target.Resize(UBound(aData, 1) + 1, UBound(aData, 2) + 1).Value = aData ''<--- Gán mảng xuống sheet
    Next
  End With
  Application.ScreenUpdating = True
  MsgBox "Done!", , Format(Timer - t, "0.000")
End Sub
Giờ chỉ cần nhấn nút và.. rung đùi thôi
--------------------------------

Dùng ADO sẽ khỏi cần lo mấy vụ lẻ tẻ này
Ẹc... Ẹc...
Nhấp chuột vào đây để mở rộng...

Cho mình hỏi

- Sau khi nhấn vào nút tổng hợp lần nữa thì dữ liệu cũ có xóa đi không
 
Upvote 0
ndu96081631 đã viết:
Thật ra bạn không biết cũng không sao, chỉ cần biết áp dụng khi người ta viết sẵn cho bạn đoạn code
Ví dụ tôi viết code ADO để lấy dữ liệu từ 1 file thế này:
Mã: 
Function GetData(ByVal FileName As String, ByVal SheetName As String, ByVal RangeAddress As String, _
            ByVal HasTitle As Boolean, ByVal UseTitle As Boolean)
            
  Dim rsCon As Object, rsData As Object, cat As Object, tbl As Object
  Dim tmpArr, Arr()
  Dim szConnect As String, szSQL As String
  Dim lCount As Long, lR As Long, lC As Long
  
  Set rsCon = CreateObject("ADODB.Connection")
  Set rsData = CreateObject("ADODB.Recordset")
  Set cat = CreateObject("ADOX.Catalog")
  
  If Val(Application.Version) < 12 Then
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FileName & ";" & _
                "Extended Properties=""Excel 8.0;HDR=" & IIf(HasTitle, "Yes", "No") & """;"
  Else
    szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";" & _
                "Extended Properties=""Excel 12.0;HDR=" & IIf(HasTitle, "Yes", "No") & """;"
  End If
  
  rsCon.Open szConnect
  cat.ActiveConnection = rsCon
  
  If SheetName = "" Then
    For Each tbl In cat.Tables
      If (Right(tbl.Name, 1) = "$") Or (Right(tbl.Name, 2) = "$'") Then
        SheetName = tbl.Name
        Exit For
      End If
    Next
  End If
  If Right(SheetName, 1) = "'" Then SheetName = Mid(SheetName, 2, Len(SheetName) - 2)
  If Right(SheetName, 1) <> "$" Then SheetName = SheetName & "$"
  szSQL = "SELECT * FROM [" & SheetName & RangeAddress & "];"
  rsData.Open szSQL, rsCon, 0, 1, 1
  tmpArr = rsData.GetRows
  ReDim Arr(UBound(tmpArr, 2) - UseTitle, UBound(tmpArr, 1) + 1)
  If UseTitle Then
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
      Arr(0, lC) = rsData.Fields(lC).Name
    Next
  End If
  For lR = LBound(tmpArr, 2) To UBound(tmpArr, 2)
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
      Arr(lR - UseTitle, lC) = tmpArr(lC, lR)
    Next
  Next
  rsData.Close: Set rsData = Nothing
  rsCon.Close: Set rsCon = Nothing
  GetData = Arr
End Function
Vậy bạn chỉ cần biết dùng cú pháp hàm là được
Mã: 
[B]GetData(Tên file cần lấy dữ liệu, Tên Sheet, Địa chỉ vùng dữ liệu, Dữ liệu có tiêu đề không?, Có lấy luôn tiêu đề không?)[/B]
Dựa vào cú pháp trên, ta viết thêm 1 Sub để gán vào nút nhấn:
Mã: 
Sub Main()
  Dim aWks(), aData
  Dim j As Long, t As Double
  Dim fleName As String, SheetName As String, sAddress As String, Target As Range
  t = Timer
  Application.ScreenUpdating = False
  aWks = Array("Lop1A", "Lop2B", "Lop3C") ''<---Tên các sheet ở file ChiTiet.xls
  sAddress = "A3:E1000" ''<--- Địa chỉ vùng dữ liệu cần lấy
  With ThisWorkbook
    fleName = .Path & "\Chitiet.xls" ''<--- Đường dẫn đến file ChiTiet.xls
    For j = 0 To UBound(aWks)
      SheetName = aWks(j)
      aData = GetData(fleName, SheetName, sAddress, False, False) ''<--- Lấy dữ liệu từ file Chitiet.xls và trả về kết quả là 1 mảng
      Set Target = .Sheets("TH").Range("F60000").End(xlUp).Offset(1) ''<--- Nơi đặt kết quả
      Target.Resize(UBound(aData, 1) + 1, UBound(aData, 2) + 1).Value = aData ''<--- Gán mảng xuống sheet
    Next
  End With
  Application.ScreenUpdating = True
  MsgBox "Done!", , Format(Timer - t, "0.000")
End Sub
Giờ chỉ cần nhấn nút và.. rung đùi thôi
--------------------------------

Dùng ADO sẽ khỏi cần lo mấy vụ lẻ tẻ này
Ẹc... Ẹc...
Nhấp chuột vào đây để mở rộng...





Thầy ơi

Nếu em thêm nhiều file nữa thì phải sửa code sao để file tổng hiểu àh

Em cảm ơn Thầy nhiều...
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

Bài viết mới nhất

B
Sau 1 tháng Mã Lại reset về 1 trở lên (1 người xem)
Trả lời
17
Đọc
175
HieuCD
H
H
Đánh số thứ thự phiếu thu chi
Trả lời
14
Đọc
212
LOGANWover
L
H
  • Question Question
Xin giúp đỡ về tạo hàm excel với C# và excel-dna
Trả lời
0
Đọc
42
hdcv.excel
H
N
  • Question Question
Cho em hỏi về mail merge bằng vba
Trả lời
5
Đọc
125
Hoàng Tuấn 868
H
T
Khóa cột cập nhật dữ liệu
Trả lời
0
Đọc
41
tnkhanhvy
T
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
3 4 5
Trả lời
411
Đọc
50K
ongke0711
ongke0711
H
Tìm kiếm thông tin chi tiết trên sheet tổng hợp
Trả lời
1
Đọc
61
LOGANWover
L
T
Xin hỏi về bảng lương (1 người xem)
Trả lời
0
Đọc
62
tuandovn
T
Gà Công Nghệ
Tô màu họ và tên bị trùng từ 2 sheet khác nhau (1 người xem)
Trả lời
6
Đọc
124
Gà Công Nghệ
Gà Công Nghệ
A
  • Question Question
Giải thích giúp mình code giải phóng bộ nhớ từ biến
Trả lời
20
Đọc
9K
nguyendang95
N
Nguyenkhang2404
giúp đỡ lọc dữ liệu nâng cao
Trả lời
22
Đọc
745
Phan Thế Hiệp
Phan Thế Hiệp
B
Dùng button trên forrm để gọi bàn phím ảo win 10(OSK)
Trả lời
5
Đọc
129
huhumalu
H
P
VẼ ĐƯỜNG TẦN SUẤT (DTS) TRÊN EXCEL
Trả lời
8
Đọc
210
ptm0412
ptm0412
P
GOAL SEEK NÂNG CAO TRONG EXCEL
    • Thích
Trả lời
4
Đọc
219
Hoale85
H
B
Gán Phím Tắt Gọi Form
Trả lời
7
Đọc
120
HeSanbi
HeSanbi
K
Điền giá trị ô thay vì địa chỉ ô
Trả lời
2
Đọc
132
LOGANWover
L
G
Chia sẻ các bạn File vẽ kèo Zamil từ excel
    • Thích
    • Yêu thích
Trả lời
11
Đọc
923
trqt82
T
T
Xin trợ giúp cách lọc trùng về khoảng thời gian
Trả lời
10
Đọc
2K
Phan Thế Hiệp
Phan Thế Hiệp
L
Xin hàm trích xuất chuỗi trong ô
Trả lời
12
Đọc
229
LINH7979
L
H
[Xin giúp đỡ] Tìm thời gian trùng ở nhiều khoảng thời gian khác nhau.
Trả lời
14
Đọc
2K
Phan Thế Hiệp
Phan Thế Hiệp
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom