Tổng hợp dữ liệu từ nhiều file excel vào 1 file không cần mở file

Liên hệ QC

ffcb1900

Thành viên chính thức
Tham gia
27/7/08
Bài viết
77
Được thích
4
Mình lúc nào cũng sẽ có 5 file dữ liệu (mỗi file khoảng 2000-5000 dòng dữ liệu), download trực tiếp hàng ngày từ server với định dạng định sẵn dưới định dạng .xls (số cột và vị trí cột định sẵn theo mẫu đính kèm là các file CA1, CA2, CA3, CA4, CA5).

Mình cần tổng hợp lại 5 file vào 1 file duy nhất (như mẫu đính kèm) trong đó du liệu của các file CA1, CA2, CA3, CA4, CA5 sẽ nối tiếp nhau ghep vào 1 sheet theo đúng cột tương ứng. Để tổng hợp đc mà k cần mở cả 5 file lên là tốt nhất (như kiểu paste link và có linh external data vậy).

Mong mọi người giúp đỡ với
 

File đính kèm

  • tong hop du lieu vao 1 file.zip
    35.1 KB · Đọc: 951
Dùng ADO sẽ không cần mở file:
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, tmp As String
  Dim lCount As Long, lR As Long, lC As Long, lVer As Long
  lVer = Val(Application.Version)
  Set rsCon = CreateObject("ADODB.Connection")
  Set rsData = CreateObject("ADODB.Recordset")
  Set cat = CreateObject("ADOX.Catalog")
  
  If lVer < 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
  If SheetName = "" Then
    Dim Dbs  As Object, db As Object
    Set Dbs = CreateObject("DAO.DBEngine." & IIf(lVer < 12, "36", "120"))
    Set db = Dbs.OpenDatabase(FileName, False, False, "Excel 8.0;")
    tmp = db.TableDefs(0).Name
    tmp = Replace(tmp, " ", "?")
    tmp = Replace(tmp, "'", " ")
    tmp = WorksheetFunction.Trim(tmp)
    tmp = Replace(tmp, " ", "'")
    tmp = Replace(tmp, "?", " ")
    SheetName = tmp
    db.Close
    Set Dbs = Nothing: Set db = Nothing
  End If
  If Right(SheetName, 1) <> "$" Then SheetName = SheetName & "$"
  rsCon.Open szConnect
  cat.ActiveConnection = rsCon
  
  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

Sub Main()
  Dim vFile, FileItem, aRes, Target As Range
  Dim FileName As String, SheetName As String, RangeAddress As String
  On Error Resume Next
  vFile = Application.GetOpenFilename("Excel File, *.xls; *.xlsx; *.xlsm", , , , True)
  If TypeName(vFile) = "Variant()" Then
    SheetName = "Sheet1": RangeAddress = "A8:V10000"
    For Each FileItem In vFile
      FileName = CStr(FileItem)
      If UCase(FileName) <> UCase(ThisWorkbook.FullName) Then
        aRes = GetData(FileName, SheetName, RangeAddress, False, False)
        If IsArray(aRes) Then
          Set Target = Sheet1.Range("A60000").End(xlUp).Offset(1)
          Target.Resize(UBound(aRes, 1) + 1, UBound(aRes, 2) + 1).Value = aRes
        End If
      End If
    Next
    MsgBox "Done!"
  End If
End Sub
Cách dùng:
- Cho code trên vào Module
- Chạy sub Main
- Cửa sổ Open File hiện ra, dùng chuột chọn file đầu, bấm giữ phím Shift rồi còn file cuối ---> Bấm nút Open
- Chờ trong giây lát, khi MsgBox hiện ra báo hiệu hoàn tất, kiểm tra lại dữ liệu trong file hiện hành xem đã cập nhật chưa
-------------
Lưu ý: File TongHop phải được lưu theo định dạng XLSM (nếu lưu bằng XLSX sẽ mất sạch code)

Bạn cho hỏi khi tên sheet ở các file nguồn của tôi có tên là "dữ liệu" không phải có tên là sheet1 thì code của bạn phải sửa dòng nào và sửa như thế nào vậy.
Cảm ơn.
 
Upvote 0
Upvote 0
Xin chào các anh chị trên diễn đàn
Ở bài #3 Thầy ndu có tạo một hàm và sub Main để tổng hợp nhiều file excel vào 1 file nhưng thí dụ có 1 file excel trống (không có số liệu hoặc chỉ có tiêu đề) thì kết quả khi chạy sẽ lấy số liệu file trước đó gán vào file trống này (ví dụ file CA1 có 4 dòng số liệu file CA6 trống nếu lấy CA1 trước CA6 thì kết quả sẽ là 8 dòng CA1)
Xin hỏi các anh chị trên diễn đàn cùng thầy ndu mình sửa code như thế nào để kết quả ra đúng
Cám ơn các anh chị rất nhiều

bạn thêm dòng màu đỏ này vào là ok nhé.
Mã:
Sub Main()
  Dim vFile, FileItem, aRes, Target As Range
  Dim FileName As String, SheetName As String, RangeAddress As String
  On Error Resume Next
  vFile = Application.GetOpenFilename("Excel File, *.xls; *.xlsx; *.xlsm", , , , True)
  If TypeName(vFile) = "Variant()" Then
    SheetName = "Sheet1": RangeAddress = "A8:V10000"
    For Each FileItem In vFile
      [COLOR=#ff0000]aRes = Nothing[/COLOR]
      FileName = CStr(FileItem)
      If UCase(FileName) <> UCase(ThisWorkbook.FullName) Then
        aRes = GetData(FileName, SheetName, RangeAddress, False, False)
        If IsArray(aRes) Then
          Set Target = Sheet1.Range("A60000").End(xlUp).Offset(1)
          Target.Resize(UBound(aRes, 1) + 1, UBound(aRes, 2) + 1).Value = aRes
        End If
      End If
    Next
    MsgBox "Done!"
  End If 
End Sub
 
Upvote 0
Chào thầy ndu và mọi người,Mình dùng file hướng dẫn của thầy ndu, đang mày mò áp dụng nhưng có yêu cầu hơi khó hơn là các file con có nhiều sheet khác nhau, và các sheet này sẽ dc copy tương ứng vào các sheet trong file tổng hợp.Mình đã làm thử nhưng nó bị lỗi sửa mãi ko dc, hix hix. Mình up file lên đây, mong thầy ndu & các bác sửa giúp ah.Cám ơn mọi người trên gpexcel nhiều!
 

File đính kèm

  • File tong hop.zip
    160.8 KB · Đọc: 46
Upvote 0
Chào thầy ndu và mọi người,Mình dùng file hướng dẫn của thầy ndu, đang mày mò áp dụng nhưng có yêu cầu hơi khó hơn là các file con có nhiều sheet khác nhau, và các sheet này sẽ dc copy tương ứng vào các sheet trong file tổng hợp (tên các sheet trong file tổng hợp giống với các sheet trong file con).Mình đã làm thử nhưng nó bị lỗi sửa mãi ko dc, hix hix. Mình up file lên đây, mong thầy ndu & các bác sửa giúp ah.Cám ơn mọi người trên gpexcel nhiều!


Các thầy/ các bạn giúp mình với nhé :(
 
Upvote 0
Các thầy/ các bạn giúp mình với nhé :(
các file có cấu trúc cột dòng khác nhau, dữ liệu minh họa và giải thích quá sơ sài, nên code khó viết đúng ý
Mã:
Sub TongHop()
  Dim Wb As Workbook, WbMain As Workbook, Ws As Worksheet, Dic As Object, Fso As Object, ObjFoder As Object, ObjFile As Object
  Dim Darr(), ShArr(), ShName As String, Tem
  Dim i As Integer, j As Integer, k As Integer, FistC As Byte, LastC As Long, FistR As Byte, LastR As Long
  Application.ScreenUpdating = False
  Set WbMain = ThisWorkbook
  Set Dic = CreateObject("scripting.dictionary")
  ReDim ShArr(i To WbMain.Sheets.Count)
  For k = 1 To WbMain.Sheets.Count
    ShArr(k) = 2
    With WbMain.Sheets(k)
      Dic.Add .Name, k
      LastR = .Range("A" & Rows.Count).End(xlUp).Row
      LastC = .Range("A1").End(xlToRight).Column
      If LastR > 1 And LastC < 16000 Then .Range("A2").Resize(LastR - 1, LastC).ClearContents
    End With
  Next k
  Set Fso = CreateObject("Scripting.FileSystemObject")
  Set ObjFoder = Fso.GetFolder(ThisWorkbook.Path)
  For Each ObjFile In ObjFoder.Files
    If Right(ObjFile, Len(WbMain.Name)) <> WbMain.Name And Fso.GetExtensionName(ObjFile) Like "xls*" Then
      Set Wb = Workbooks.Open(ObjFile)
      For Each Ws In Wb.Sheets
        ShName = Ws.Name
        If Dic.exists(ShName) Then
          If ShName = "Product_Location_3a" Then
            FistR = 3:  FistC = 2
          ElseIf ShName = "Product_Global" Then
            FistR = 3:  FistC = 1
          Else
            FistR = 2:  FistC = 1
          End If
          LastR = Ws.Range("B" & Rows.Count).End(xlUp).Row
          If LastR >= FistR Then
            LastC = Ws.Range("A1").End(xlToRight).Column
            Darr = Ws.Range(Ws.Cells(FistR, FistC), Ws.Cells(LastR, LastC)).Value
            k = Dic.Item(ShName)
            WbMain.Sheets(k).Range("B" & ShArr(k)).Resize(UBound(Darr), UBound(Darr, 2)) = Darr
            ShArr(k) = ShArr(k) + UBound(Darr)
          End If
        End If
      Next Ws
      Wb.Close False
    End If
  Next
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
các file có cấu trúc cột dòng khác nhau, dữ liệu minh họa và giải thích quá sơ sài, nên code khó viết đúng ý
Mã:
Sub TongHop()
  Dim Wb As Workbook, WbMain As Workbook, Ws As Worksheet, Dic As Object, Fso As Object, ObjFoder As Object, ObjFile As Object
  Dim Darr(), ShArr(), ShName As String, Tem
  Dim i As Integer, j As Integer, k As Integer, FistC As Byte, LastC As Long, FistR As Byte, LastR As Long
  Application.ScreenUpdating = False
  Set WbMain = ThisWorkbook
  Set Dic = CreateObject("scripting.dictionary")
  ReDim ShArr(i To WbMain.Sheets.Count)
  For k = 1 To WbMain.Sheets.Count
    ShArr(k) = 2
    With WbMain.Sheets(k)
      Dic.Add .Name, k
      LastR = .Range("A" & Rows.Count).End(xlUp).Row
      LastC = .Range("A1").End(xlToRight).Column
      If LastR > 1 And LastC < 16000 Then .Range("A2").Resize(LastR - 1, LastC).ClearContents
    End With
  Next k
  Set Fso = CreateObject("Scripting.FileSystemObject")
  Set ObjFoder = Fso.GetFolder(ThisWorkbook.Path)
  For Each ObjFile In ObjFoder.Files
    If Right(ObjFile, Len(WbMain.Name)) <> WbMain.Name And Fso.GetExtensionName(ObjFile) Like "xls*" Then
      Set Wb = Workbooks.Open(ObjFile)
      For Each Ws In Wb.Sheets
        ShName = Ws.Name
        If Dic.exists(ShName) Then
          If ShName = "Product_Location_3a" Then
            FistR = 3:  FistC = 2
          ElseIf ShName = "Product_Global" Then
            FistR = 3:  FistC = 1
          Else
            FistR = 2:  FistC = 1
          End If
          LastR = Ws.Range("B" & Rows.Count).End(xlUp).Row
          If LastR >= FistR Then
            LastC = Ws.Range("A1").End(xlToRight).Column
            Darr = Ws.Range(Ws.Cells(FistR, FistC), Ws.Cells(LastR, LastC)).Value
            k = Dic.Item(ShName)
            WbMain.Sheets(k).Range("B" & ShArr(k)).Resize(UBound(Darr), UBound(Darr, 2)) = Darr
            ShArr(k) = ShArr(k) + UBound(Darr)
          End If
        End If
      Next Ws
      Wb.Close False
    End If
  Next
  Application.ScreenUpdating = True
End Sub


Chào bác, cám ơn bác rất nhiều vì đã đọc bài viết và làm giúp em. Nhưng mà em bỏ vô file chạy thử thì bị lỗi rùi nên chưa test tiếp dc, em up lên đây bác xem thử nha. Em đang tiếp cận bài toán theo cách khác. Nhưng nếu bác sửa dc thì cũng sẽ giúp rất nhiều cho em.

Cám ơn bác nhé!
 

File đính kèm

  • New folder.zip
    161.6 KB · Đọc: 19
Upvote 0
Chào bác, cám ơn bác rất nhiều vì đã đọc bài viết và làm giúp em. Nhưng mà em bỏ vô file chạy thử thì bị lỗi rùi nên chưa test tiếp dc, em up lên đây bác xem thử nha. Em đang tiếp cận bài toán theo cách khác. Nhưng nếu bác sửa dc thì cũng sẽ giúp rất nhiều cho em.
Cám ơn bác nhé!
bạn xem lại file bạn gởi bài trước và bài nầy có giống nhau không? cụ thể là sheet Product_Location_3a của file Part...
 
Upvote 0
bạn xem lại file bạn gởi bài trước và bài nầy có giống nhau không? cụ thể là sheet Product_Location_3a của file Part...

Cám ơn bác nhiều nhé. Em đã check lại và làm dc rồi. ko hiểu sao cái file Part...lúc sau lại bị đổi so vơi lúc e gữi file lên diễn đàn nữa.

Giải pháp excel luôn là cứu cánh của mình khi gặp khó khăn với excel!
 
Upvote 0
Các bạn xem giúp mình dữ liệu cột F(data6) không lấy vào file TONG HOP được.
Chân thành cảm ơn
 

File đính kèm

  • TH.rar
    71 KB · Đọc: 14
Upvote 0
Dùng ADO sẽ không cần mở file:
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, tmp As String
  Dim lCount As Long, lR As Long, lC As Long, lVer As Long
  lVer = Val(Application.Version)
  Set rsCon = CreateObject("ADODB.Connection")
  Set rsData = CreateObject("ADODB.Recordset")
  Set cat = CreateObject("ADOX.Catalog")
 
  If lVer < 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
  If SheetName = "" Then
    Dim Dbs  As Object, db As Object
    Set Dbs = CreateObject("DAO.DBEngine." & IIf(lVer < 12, "36", "120"))
    Set db = Dbs.OpenDatabase(FileName, False, False, "Excel 8.0;")
    tmp = db.TableDefs(0).Name
    tmp = Replace(tmp, " ", "?")
    tmp = Replace(tmp, "'", " ")
    tmp = WorksheetFunction.Trim(tmp)
    tmp = Replace(tmp, " ", "'")
    tmp = Replace(tmp, "?", " ")
    SheetName = tmp
    db.Close
    Set Dbs = Nothing: Set db = Nothing
  End If
  If Right(SheetName, 1) <> "$" Then SheetName = SheetName & "$"
  rsCon.Open szConnect
  cat.ActiveConnection = rsCon
 
  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

Sub Main()
  Dim vFile, FileItem, aRes, Target As Range
  Dim FileName As String, SheetName As String, RangeAddress As String
  On Error Resume Next
  vFile = Application.GetOpenFilename("Excel File, *.xls; *.xlsx; *.xlsm", , , , True)
  If TypeName(vFile) = "Variant()" Then
    SheetName = "Sheet1": RangeAddress = "A8:V10000"
    For Each FileItem In vFile
      FileName = CStr(FileItem)
      If UCase(FileName) <> UCase(ThisWorkbook.FullName) Then
        aRes = GetData(FileName, SheetName, RangeAddress, False, False)
        If IsArray(aRes) Then
          Set Target = Sheet1.Range("A60000").End(xlUp).Offset(1)
          Target.Resize(UBound(aRes, 1) + 1, UBound(aRes, 2) + 1).Value = aRes
        End If
      End If
    Next
    MsgBox "Done!"
  End If
End Sub
Cách dùng:
- Cho code trên vào Module
- Chạy sub Main
- Cửa sổ Open File hiện ra, dùng chuột chọn file đầu, bấm giữ phím Shift rồi còn file cuối ---> Bấm nút Open
- Chờ trong giây lát, khi MsgBox hiện ra báo hiệu hoàn tất, kiểm tra lại dữ liệu trong file hiện hành xem đã cập nhật chưa
-------------
Lưu ý: File TongHop phải được lưu theo định dạng XLSM (nếu lưu bằng XLSX sẽ mất sạch code)
Cho em hỏi chút. Em muốn chèn thêm 1 cột đầu tiên trong File TongHop lấy tên các file gộp theo từng dòng thì làm thế nào ạ.
 
Upvote 0
Dùng ADO sẽ không cần mở file:
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, tmp As String
  Dim lCount As Long, lR As Long, lC As Long, lVer As Long
  lVer = Val(Application.Version)
  Set rsCon = CreateObject("ADODB.Connection")
  Set rsData = CreateObject("ADODB.Recordset")
  Set cat = CreateObject("ADOX.Catalog")
 
  If lVer < 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
  If SheetName = "" Then
    Dim Dbs  As Object, db As Object
    Set Dbs = CreateObject("DAO.DBEngine." & IIf(lVer < 12, "36", "120"))
    Set db = Dbs.OpenDatabase(FileName, False, False, "Excel 8.0;")
    tmp = db.TableDefs(0).Name
    tmp = Replace(tmp, " ", "?")
    tmp = Replace(tmp, "'", " ")
    tmp = WorksheetFunction.Trim(tmp)
    tmp = Replace(tmp, " ", "'")
    tmp = Replace(tmp, "?", " ")
    SheetName = tmp
    db.Close
    Set Dbs = Nothing: Set db = Nothing
  End If
  If Right(SheetName, 1) <> "$" Then SheetName = SheetName & "$"
  rsCon.Open szConnect
  cat.ActiveConnection = rsCon
 
  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

Sub Main()
  Dim vFile, FileItem, aRes, Target As Range
  Dim FileName As String, SheetName As String, RangeAddress As String
  On Error Resume Next
  vFile = Application.GetOpenFilename("Excel File, *.xls; *.xlsx; *.xlsm", , , , True)
  If TypeName(vFile) = "Variant()" Then
    SheetName = "Sheet1": RangeAddress = "A8:V10000"
    For Each FileItem In vFile
      FileName = CStr(FileItem)
      If UCase(FileName) <> UCase(ThisWorkbook.FullName) Then
        aRes = GetData(FileName, SheetName, RangeAddress, False, False)
        If IsArray(aRes) Then
          Set Target = Sheet1.Range("A60000").End(xlUp).Offset(1)
          Target.Resize(UBound(aRes, 1) + 1, UBound(aRes, 2) + 1).Value = aRes
        End If
      End If
    Next
    MsgBox "Done!"
  End If
End Sub
Cách dùng:
- Cho code trên vào Module
- Chạy sub Main
- Cửa sổ Open File hiện ra, dùng chuột chọn file đầu, bấm giữ phím Shift rồi còn file cuối ---> Bấm nút Open
- Chờ trong giây lát, khi MsgBox hiện ra báo hiệu hoàn tất, kiểm tra lại dữ liệu trong file hiện hành xem đã cập nhật chưa
-------------
Lưu ý: File TongHop phải được lưu theo định dạng XLSM (nếu lưu bằng XLSX sẽ mất sạch code)

Chào anh. Em thấy code này chạy tốt. Vậy nếu các sheet cần lấy dữ liệu ở đây là sheet2 của CA1.xlsx; CA2.xlsx thì dòng code mình phải điều chỉnh như thế nào để lấy dữ liệu đúng sheet. Xin cảm ơn
 
Upvote 0
Dùng ADO sẽ không cần mở file:
Mã:
em chào anh ndu96081631.
như file anh giới thiệu thì đang tổng hợp theo dòng , em muốn chuyển code để tổng hợp theo cột thì mình phải thay đổi code thế nào. 
mong anh chỉ giúp,


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, tmp As String
  Dim lCount As Long, lR As Long, lC As Long, lVer As Long
  lVer = Val(Application.Version)
  Set rsCon = CreateObject("ADODB.Connection")
  Set rsData = CreateObject("ADODB.Recordset")
  Set cat = CreateObject("ADOX.Catalog")
 
  If lVer < 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
  If SheetName = "" Then
    Dim Dbs  As Object, db As Object
    Set Dbs = CreateObject("DAO.DBEngine." & IIf(lVer < 12, "36", "120"))
    Set db = Dbs.OpenDatabase(FileName, False, False, "Excel 8.0;")
    tmp = db.TableDefs(0).Name
    tmp = Replace(tmp, " ", "?")
    tmp = Replace(tmp, "'", " ")
    tmp = WorksheetFunction.Trim(tmp)
    tmp = Replace(tmp, " ", "'")
    tmp = Replace(tmp, "?", " ")
    SheetName = tmp
    db.Close
    Set Dbs = Nothing: Set db = Nothing
  End If
  If Right(SheetName, 1) <> "$" Then SheetName = SheetName & "$"
  rsCon.Open szConnect
  cat.ActiveConnection = rsCon
 
  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

Sub Main()
  Dim vFile, FileItem, aRes, Target As Range
  Dim FileName As String, SheetName As String, RangeAddress As String
  On Error Resume Next
  vFile = Application.GetOpenFilename("Excel File, *.xls; *.xlsx; *.xlsm", , , , True)
  If TypeName(vFile) = "Variant()" Then
    SheetName = "Sheet1": RangeAddress = "A8:V10000"
    For Each FileItem In vFile
      FileName = CStr(FileItem)
      If UCase(FileName) <> UCase(ThisWorkbook.FullName) Then
        aRes = GetData(FileName, SheetName, RangeAddress, False, False)
        If IsArray(aRes) Then
          Set Target = Sheet1.Range("A60000").End(xlUp).Offset(1)
          Target.Resize(UBound(aRes, 1) + 1, UBound(aRes, 2) + 1).Value = aRes
        End If
      End If
    Next
    MsgBox "Done!"
  End If
End Sub
Cách dùng:
- Cho code trên vào Module
- Chạy sub Main
- Cửa sổ Open File hiện ra, dùng chuột chọn file đầu, bấm giữ phím Shift rồi còn file cuối ---> Bấm nút Open
- Chờ trong giây lát, khi MsgBox hiện ra báo hiệu hoàn tất, kiểm tra lại dữ liệu trong file hiện hành xem đã cập nhật chưa
-------------
Lưu ý: File TongHop phải được lưu theo định dạng XLSM (nếu lưu bằng XLSX sẽ mất sạch code)
 
Upvote 0
các file có cấu trúc cột dòng khác nhau, dữ liệu minh họa và giải thích quá sơ sài, nên code khó viết đúng ý
Mã:
Sub TongHop()
  Dim Wb As Workbook, WbMain As Workbook, Ws As Worksheet, Dic As Object, Fso As Object, ObjFoder As Object, ObjFile As Object
  Dim Darr(), ShArr(), ShName As String, Tem
  Dim i As Integer, j As Integer, k As Integer, FistC As Byte, LastC As Long, FistR As Byte, LastR As Long
  Application.ScreenUpdating = False
  Set WbMain = ThisWorkbook
  Set Dic = CreateObject("scripting.dictionary")
  ReDim ShArr(i To WbMain.Sheets.Count)
  For k = 1 To WbMain.Sheets.Count
    ShArr(k) = 2
    With WbMain.Sheets(k)
      Dic.Add .Name, k
      LastR = .Range("A" & Rows.Count).End(xlUp).Row
      LastC = .Range("A1").End(xlToRight).Column
      If LastR > 1 And LastC < 16000 Then .Range("A2").Resize(LastR - 1, LastC).ClearContents
    End With
  Next k
  Set Fso = CreateObject("Scripting.FileSystemObject")
  Set ObjFoder = Fso.GetFolder(ThisWorkbook.Path)
  For Each ObjFile In ObjFoder.Files
    If Right(ObjFile, Len(WbMain.Name)) <> WbMain.Name And Fso.GetExtensionName(ObjFile) Like "xls*" Then
      Set Wb = Workbooks.Open(ObjFile)
      For Each Ws In Wb.Sheets
        ShName = Ws.Name
        If Dic.exists(ShName) Then
          If ShName = "Product_Location_3a" Then
            FistR = 3:  FistC = 2
          ElseIf ShName = "Product_Global" Then
            FistR = 3:  FistC = 1
          Else
            FistR = 2:  FistC = 1
          End If
          LastR = Ws.Range("B" & Rows.Count).End(xlUp).Row
          If LastR >= FistR Then
            LastC = Ws.Range("A1").End(xlToRight).Column
            Darr = Ws.Range(Ws.Cells(FistR, FistC), Ws.Cells(LastR, LastC)).Value
            k = Dic.Item(ShName)
            WbMain.Sheets(k).Range("B" & ShArr(k)).Resize(UBound(Darr), UBound(Darr, 2)) = Darr
            ShArr(k) = ShArr(k) + UBound(Darr)
          End If
        End If
      Next Ws
      Wb.Close False
    End If
  Next
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
Chào Anh/Chị và Các bạn diễn đàn GPE,
File CA1&CA3 mình sửa tên Sheet1 thành "Data", trong code mình cũng sửa Sheet1 thành "Data".
Nhưng khi mình tổng hợp nếu lỡ chọn cả 03 file CA1, CA2 và CA3(file CA2 không có Sheet "Data") thì kết dữ liệu file CA2 vẫn được tổng hợp.
Anh chị và các bạn xem giúp dùm mình nếu lỡ chọn những file không có tên Sheet cần tổng hợp thì dữ liệu không được tổng hợp vào.
Fle mình nêu ra đây là một ví dụ cụ thể.
Rất mong nhận được sự giúp đỡ của anh, chị và các bạn trên diễn đàn GPE.
Chân thành cám ơn.
 

File đính kèm

  • tong hop du lieu vao 1 file.rar
    41.3 KB · Đọc: 33
Upvote 0
code gộp dữ liệu của thành viên meoluoi2010 cũng rất tốt
 

File đính kèm

  • gopfile.rar
    23.1 KB · Đọc: 154
Upvote 0
Bạn chạy mỗi code này. Còn code trong file tôi không sửa nha

Mã:
Option Explicit

Public Sub GPE()
Dim FOb As Object, Fso As Object, Item, cn As Object, rs As Object, fOld As String, fNew As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Fso = CreateObject("Scripting.FileSystemObject")
Set cn = CreateObject("ADODB.Connection")
If Application.Version < 12 Then
    fOld = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
    fNew = ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
Else
    fOld = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="
    fNew = ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1"";"
End If
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .Filters.Add "Microsoft Excel Files", "*.xls*", 1
    If Not .Show = -1 Then
        MsgBox "Ban chua chon File", vbInformation, "----Mr.GPE----"
        Exit Sub
    End If
Range("A7").CurrentRegion.Offset(1).ClearContents
On Error Resume Next
For Each Item In .SelectedItems
    If Left(Item, 1) <> "~" Then
        cn.Open (fOld & Item & fNew)
            Set rs = cn.Execute("select * from [Data$A8:V] where F1 Is Not Null")
            If Not rs.EOF Then Range("A65000").End(3)(2).CopyFromRecordset rs
            rs.Close
            cn.Close
    End If
Next Item
End With
Set cn = Nothing
Set rs = Nothing
MsgBox "Done!"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Mình cảm ơn bạn hpkhuong nhé, mình sẽ sử dụng code này và trong quá trình sử dụng nếu có phát sinh vấn đề cần chỉnh sửa thì rất mong nhận được sự giúp đỡ của bạn.
Chân thành cảm ơn.
 
Upvote 0
Các bác cho hỏi làm sao lấy dữ liệu mà dàn hàng ngang thay vì nối tiếp theo cột ko a

như ví du #1
 

File đính kèm

  • tong hop du lieu vao 1 file.rar
    53.9 KB · Đọc: 20
Upvote 0
Xin hỏi thêm là nếu muốn tự động đọc các file theo [Danh sách], copy dữ liệu từ 1 vùng dữ liệu thỏa mãn điều kiện vào vùng tương ứng trong file tổng hợp thì
Bạn chạy mỗi code này. Còn code trong file tôi không sửa nha

Mã:
Option Explicit

Public Sub GPE()
Dim FOb As Object, Fso As Object, Item, cn As Object, rs As Object, fOld As String, fNew As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Fso = CreateObject("Scripting.FileSystemObject")
Set cn = CreateObject("ADODB.Connection")
If Application.Version < 12 Then
    fOld = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
    fNew = ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
Else
    fOld = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="
    fNew = ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1"";"
End If
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .Filters.Add "Microsoft Excel Files", "*.xls*", 1
    If Not .Show = -1 Then
        MsgBox "Ban chua chon File", vbInformation, "----Mr.GPE----"
        Exit Sub
    End If
Range("A7").CurrentRegion.Offset(1).ClearContents
On Error Resume Next
For Each Item In .SelectedItems
    If Left(Item, 1) <> "~" Then
        cn.Open (fOld & Item & fNew)
            Set rs = cn.Execute("select * from [Data$A8:V] where F1 Is Not Null")
            If Not rs.EOF Then Range("A65000").End(3)(2).CopyFromRecordset rs
            rs.Close
            cn.Close
    End If
Next Item
End With
Set cn = Nothing
Set rs = Nothing
MsgBox "Done!"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Xin hỏi thêm là nếu muốn tự động đọc các file theo [Danh sách] đã có, copy dữ liệu theo [điều kiện] vào vùng tương ứng trong file tổng hợp thì đoạn code cần bổ sung thêm thế nào vậy bạn?
 
Upvote 0
Web KT

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

Back
Top Bottom