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

10 Responses

1. hands says:

   03/12/2022 at 9:11 am

   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

   Dùng ADO sẽ không cần mở file:

   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)

   http://www.giaiphapexcel.com/diendan/threads/t%E1%BB%95ng-h%E1%BB%A3p-d%E1%BB%AF-li%E1%BB%87u-t%E1%BB%AB-nhi%E1%BB%81u-file-excel-v%C3%A0o-1-file-kh%C3%B4ng-c%E1%BA%A7n-m%E1%BB%9F-file.84529/post-527079

   File của thầy ndu96081631, em thử chạy tốt. Thầy cho em hỏi, với code này, thì sẽ có những hạn chế gì mà sẽ khiến file k chạy được ạ ? Ví dụ hạn chế về số dòng, số cột, định dạng, số lượng gộp file… ? Nếu sau em có thêm file data để gộp và vùng gộp cũng thay đổi số cột thì thầy em sẽ chỉnh đoạn nào trong code để có thể tự thay đổi đc ạ?

   Bạn chỉ cần để ý Sub Main này thôi:

   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
       [COLOR=#ff0000][B]SheetName = "Sheet1"[/B][/COLOR]: [B][COLOR=#0000cd]RangeAddress = "A8:V10000"[/COLOR][/B]
       For Each FileItem In vFile
         [B][COLOR=#006400]FileName = CStr(FileItem)[/COLOR][/B]
         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

   Khai báo cho đúng: màu đỏ là tên sheet, màu xanh dương là vùng dữ liệu, xanh lá là tên file
   ———————-

   Anh ndu96081631 cho em hỏi thêm là sau khi chạy với file test thì chạy tốt. Nhưng chạy với file download xuống thì bị lỗi là:
   -Vẫn báo "Done" nhưng dữ liệu trống ko tổng hợp sang. Rất tiếc là file down xuống nằm trong máy tính của công ty mà k thế upload trực tiếp lên đc ạ

   – Nếu copy all từ file down xuống và paste all vao 1 new document. Rồi dùng file tổng hợp trỏ đến new document thì chạy ngon còn trỏ vào file down xuống thì k chạy. Liệu có restriction gì cài đặt trong file down xuống làm hạn chế này ko ạ ? Liệu có loại restriction nào như the k ạ ?

   Bạn nói chung chung thế sao tôi biết được. Khám bệnh thì phải có bệnh nhân bạn à

   Reply
2. hands says:

   03/12/2022 at 9:13 am

   Em lại làm phiền các thầy 1 chút:
   Em Copy đoạn Code của thầy và làm như hướng dẫn cho 1 file ví dụ thì chạy rất tốt nhưng khi em đưa code vào file chính thức của em lại ko chạy được. Em nghi là file tổng hợp của em có vấn đề gì đó mà em ko thể tìm ra lỗi. Em cũng hỏi thêm là vùng dữ liệu sau khi khi tổng hợp hiện tại nó đang nằm ở 1 vị trí mặc định, em muốn sửa code để vùng dữ liệu này nằm ở vị trí tùy ý thì sửa ở chỗ nào.
   Mong thầy chỉ bảo giúp em.
   Cảm ơn thầy.
   Vui lòng xem file đính kèm.

   Đoạn code Set Target = Sheet1.Range("A60000").End(xlUp).Offset(1)
   Trong file của bạn chẳng có sheet nào là Sheet1 cả
   Nên nhớ viết kiểu như thế Excel hiểu rằng đó là Sheet CodeName nha
   Cái "Sheet1" mà bạn nhìn thấy có Sheet CodeName = "Sheet6"
   Vậy, hoặc là bạn sửa đoạn code trên thành:
   Set Target = Sheet6.Range("A60000").End(xlUp).Offset(1)
   Hoặc là sửa thành:
   Set Target = Worksheets("Sheet1").Range("A60000").End(xlUp).Offset(1)
   ———————
   

   Trong khi chờ Ndu trả lời, trong sub Main bạn thử thay câu lệnh

   Set Target = Sheet1.Range("A60000").End(xlUp).Offset(1)

   thành

   Set Target = Sheet1.Range(selection)

   Lưu ý: vị trí bạn đặt con trỏ sẽ là ô đầu tiên (ô trái trên) của vùng dữ liệu. Vì vậy bạn phải chọn vị trí đặt dữ liệu trước khi chạy code

   Vầy mới đúng chứ anh Set Target = Selection

   Reply
3. hands says:

   03/12/2022 at 9:21 am

   – có thể nào cho excel tự hiểu sheet đầu tiên là sheet cần lấy dữ liệu cho dù sheet đầu tiên không phải mang tên là ''sheet1'' .
   .

   Code có tính đến trường hợp này mà bạn. Bạn cho SheetName = "" đồng nghĩa sẽ lấy Sheet đầu tiên

   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
       [COLOR=#ff0000]SheetName = ""[/COLOR]: RangeAddress = "A8:V10000"   ''<--- [COLOR=#ff0000]Gán SheetName = ""[/COLOR]
       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

   Hoặc cũng không cần gán giá trị nào cho SheetName cũng được:

   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
       RangeAddress = "A8:V10000"  [COLOR=#ff0000]''<---- Xóa luôn dòng gán giá trị cho SheetName[/COLOR]
       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

   ————————————

   – trên sheet tổng hợp chỉ nhập những dữ liệu mới , lọc bỏ những dữ liệu trùng lập .
   .
   .

   Chưa hiểu ý bạn chỗ này! Như thế nào thì gọi là dữ liệu mới

   Có khoảng 200 file con, có cách nào làm nhanh ko thầy?

   Thử code này trên 1 file trắng:

   Sub ConvertToExl2003()
     Dim vFile, FileName
     On Error Resume Next
     vFile = Application.GetOpenFilename("Excel Files, *.xls", , , , True)
     If TypeName(vFile) = "Variant()" Then
       Application.ScreenUpdating = False
       Application.DisplayAlerts = False
       For Each FileName In vFile
         With Workbooks.Open(FileName)
           .SaveAs FileName, xlExcel9795
           .Close True
         End With
       Next
       MsgBox "Thành công"
       Application.DisplayAlerts = True
       Application.ScreenUpdating = True
     End If
   End Sub

   Chạy code, hộp mở file hiện ra, chọn file đầu, bấm phím Shift và chọn file cuối rồi bấm nút Open. Chờ đến khi thông báo "Thành công" hiện ra là xong
   Để thí nghiệm, đừng chọn quá nhiều file nha. Chọn 1 vài file, sau khi code chạy xong hãy kiểm tra lại cho chắc chắn rồi hẳn tiếp tục

   Reply
4. hands says:

   03/12/2022 at 9:22 am

   Chào Thầy và các anh chi !
   Em muốn tổng hợp du lieu từ tất cả các sheet trong nhiều file vào một sheet tổng hợp. vậy code này phải sửa như thế nào?
   nhờ Thầy và các anh chi giúp.

   Xinh chân thành cảm ơn !!

   code này nhìn quen quen–=0–=0
   vui lòng xem file
   chú ý tên sheet trong file nguồn sủa thành sheet1,2,3…thì mới chạy

   gửi bài viết tháng 8 rồi tháng 10 quay lại , rồi sau hôm nay thì tháng mấy bạn quay lại ?
   muốn sửa code thì xóa hết code đang có trong file rồi ghi code này vào mà chạy

   Public Sub hello()
   Dim cn As Object, cat As Object, filename, sheetname As String, tbl As Object, vFile
   On Error Resume Next
   Set cn = CreateObject("ADODB.Connection")
   Set cat = CreateObject("ADOX.Catalog")
   vFile = Application.GetOpenFilename("Excel File, *.xl*", , , , True)
   If TypeName(vFile) = "Variant()" Then
       For Each filename In vFile
           cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & filename & _
                   ";mode=read;Extended Properties=""Excel 12.0;HDR=no"";"
           Set cat.ActiveConnection = cn
           For Each tbl In cat.tables
               If Right(tbl.Name, 1) = "$" Or Right(tbl.Name, 2) = "$'" Then
                   sheetname = " [" & Replace(tbl.Name, "'", "") & "A13:EM13]"
                   'error when range [A13:EM13] empty
                   Sheet1.Range("B100000").End(xlUp).Offset(1) _
                   .CopyFromRecordset cn.Execute("select * from " & sheetname)
               End If
           Next
           cn.Close
       Next
   End If
   End Sub

   http://www.giaiphapexcel.com/diendan/threads/t%E1%BB%95ng-h%E1%BB%A3p-d%E1%BB%AF-li%E1%BB%87u-t%E1%BB%AB-nhi%E1%BB%81u-file-excel-v%C3%A0o-1-file-kh%C3%B4ng-c%E1%BA%A7n-m%E1%BB%9F-file.84529/post-682656

   Reply
5. hands says:

   03/12/2022 at 9:23 am

   Em xin kính chào cả nhà,
   Em đã đọc hết 7 trang của Thread này – nhưng thực sự chưa thấy có nội dung nào như nội dung em cần thực hiện sau đây để áp dụng – nên em đành mạo muội viết post này và các thông tin attach, xin kính nhờ cả nhà giúp em với:
   – Em có 1 file tổng hợp – tên gọi AToZ_Summary.xls → Lưu ở 1 Folder riêng
   – Và các file chi tiết (cụ thể em attach ở đây là 8 file) → các file này lưu CHUNG ở 1 Folder riêng (không giống folder của File Summary nêu trên)

   Em cần tổng hợp số liệu từ 1 sheet của các File Chi tiết này vào File Summary như em ghi nhận Yêu cầu trong File Summary. Xin nói rõ là các File chi tiết sẽ có nhiều Sheet, không chỉ Sheet cần lấy thông tin (Sheet cần thông tin này có mã hiệu ABC) – nhưng em chỉ quan tâm cái Sheet cần lấy thông tin này mà thôi – các Sheet còn lại thì không sử dụng vào file Summary.

   Em zip toàn bộ các File này vào chung 1 folder để cả nhà dễ hình dung.

   Vậy em kính nhờ cả nhà giúp em với ạ – nội dung em thỉnh nhờ cả nhà là em đã ghi nhận trong Sheet "AToZ_Summary" của File AToZ_Summary.xls rồi ạ

   Em rất cảm ơn cả nhà đã đọc tin và em mong tin cả nhà lắm ạ
   Em chuotpt3

   1. Lúc thì "Đủ Điều kiện", lúc thì "Đủ đk" ??? Đã xây dựng dữ liệu mà không chuẩn thì có bằng không ah? –> Viết code cũng vất vả…tốn công

   2. Bài này mà bạn dùng ADO chi cho mệt vậy???

   3. Chạy code sau,-> Của sổ mở File xuất hiện -> Multi Select File (chọn 1 lần nhiều file) muốn lấy dữ liệu vào…và hưởng kết quả.

   Option Explicit
   
   Public Sub GPE()
   Dim X As Variant, Y As Long, vFile As String, Wb As Workbook, Sh As Worksheet, tSheet As String
   Dim sArr, dArr, I As Long, Dk As String, Dk1 As String, Dx As String, Dt As String
   Dim UGD As Currency, XHD As Currency, DTH As Currency
   Dk = ChrW(272) & ChrW(7911) & " " & ChrW(272) & "i" & ChrW(7873) & "u ki" & ChrW(7879) & "n"
   Dk1 = ChrW(272) & ChrW(7911) & " " & ChrW(273) & "k"
   Dx = ChrW(272) & "ã xu" & ChrW(7845) & "t"
   Dt = ChrW(272) & "ã thu"
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   X = Application.GetOpenFilename(, , , , True)
   ReDim dArr(1 To UBound(X), 1 To 12)
   If Not IsArray(X) Then Exit Sub
   For Y = 1 To UBound(X)
   vFile = Replace(X(Y), "", "", InStrRev(X(Y), ""))
   tSheet = Left(vFile, InStr(1, vFile, "_Ch") - 1)
       Set Wb = Workbooks.Open(X(Y))
       Set Sh = Wb.Sheets(tSheet)
           dArr(Y, 1) = Y: dArr(Y, 2) = Sh.[C2]: dArr(Y, 3) = Sh.[E2]
           dArr(Y, 4) = Sh.[G2]: dArr(Y, 5) = Sh.[J2]
           dArr(Y, 6) = Sh.[C3]: dArr(Y, 7) = Sh.[E3]: dArr(Y, 8) = Sh.[G3]: dArr(Y, 9) = Sh.[I3]
       sArr = Sh.Range("A13").CurrentRegion.Value
       UGD = 0: XHD = 0: DTH = 0
           For I = 2 To UBound(sArr)
               If sArr(I, 2) <> Empty Then
                   If sArr(I, 6) = Dk Or sArr(I, 6) = Dk1 Then UGD = UGD + sArr(I, 5)
                   If sArr(I, 7) = Dx Then XHD = XHD + sArr(I, 3)
                   If sArr(I, 10) = Dt Then DTH = DTH + sArr(I, 3)
               End If
           Next I
           dArr(Y, 10) = UGD: dArr(Y, 11) = XHD: dArr(Y, 12) = DTH
       Wb.Close False
   Next Y
       Range("A5").Resize(10, 12).ClearContents
       Range("A5").Resize(Y - 1, 12).Value = dArr
   Application.DisplayAlerts = True
   Application.ScreenUpdating = True
   End Sub

   http://www.giaiphapexcel.com/diendan/threads/t%E1%BB%95ng-h%E1%BB%A3p-d%E1%BB%AF-li%E1%BB%87u-t%E1%BB%AB-nhi%E1%BB%81u-file-excel-v%C3%A0o-1-file-kh%C3%B4ng-c%E1%BA%A7n-m%E1%BB%9F-file.84529/post-742758

   Reply
6. hands says:

   03/12/2022 at 9:24 am

   Kính gửi diễn đàn giaiphapexcel.com em đã xem từ đầu đến cuối 7 trang về:[URL="https://www.giaiphapexcel.com/forum/"%5DTổng hợp dữ liệu từ nhiều file excel vào 1 file không cần mở file"

   nhưng em chưa tìm ra cách giải quyết vấn đề của mình rất mong diễn đàn chỉ giúp:
   Vấn đề của em như sau:
   – Em có 1 folder: QLCV
   – Trong folder QLCV: hàng năm em tạo ra các folder theo năm như folder: 2004, 2005, 2006…
   – Trong folder QLCV: em có file excel TongHopDiDen.xls dùng để tổng hợp dữ liệu từ các sheet DataDen của các file 2004.xls, 2005.xls, 2006.xls… tương ứng trong các folder: 2004,2005,2006… vào 1 sheet THDataDen.
   Rất mong các Thầy trên diễn đàn giúp đỡ em. Em cám ơn rất nhiều.
   Vì file gốc của em rất lớn không thể gửi lên được. Em xin gửi file mẫu giống file gốc mong mọi các thầy giúp đỡ.

   https://www.mediafire.com/file/k0out1xx5xdnz16/QLVB.rar

   Bạn chạy thử đoạn sau:

   Public Sub GPE_ADO()
   Dim FOb As Object, Item As Object, Pth As String
   Dim cn As Object, rs As Object, Ws As Worksheet
   Set Ws = ThisWorkbook.Sheets("THDataDen")
   Set cn = CreateObject("ADODB.Connection")
   Pth = ThisWorkbook.Path
   Application.ScreenUpdating = False
   Ws.Range("A2").Resize(5000, 18).ClearContents
   Set FOb = CreateObject("Scripting.FileSystemObject").GetFolder(Pth)
   For Each Item In FOb.SubFolders
       cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & _
           Pth & "" & Item.Name & "" & Item.Name & ".xlsx" & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
               Set rs = cn.Execute("select * from [Den$A:R] where f1 is not null")
               If Not rs.EOF Then Ws.Range("A65000").End(3)(2).CopyFromRecordset rs
               rs.Close
               cn.Close
   Next Item
   Set cn = Nothing
   Set FOb = Nothing
   Set Item = Nothing
   MsgBox "Da Tong Hop Xong!"
   Application.ScreenUpdating = True
   End Sub

   http://www.giaiphapexcel.com/diendan/threads/t%E1%BB%95ng-h%E1%BB%A3p-d%E1%BB%AF-li%E1%BB%87u-t%E1%BB%AB-nhi%E1%BB%81u-file-excel-v%C3%A0o-1-file-kh%C3%B4ng-c%E1%BA%A7n-m%E1%BB%9F-file.84529/post-750606

   Cám ơn hpkhuong rất nhiều mình đã thử và chạy rất tốt. Nhưng khi test trên excel 2003 thì bị báo lỗi ở dòng này: Set rs = cn.Execute("select * from [Den$A:R] where f1 is not null"). Rất mong hpkhuong giúp mình lần nữa

   bạn sủa những chố sau xem
   Microsoft.ACE.OLEDB.12.0

   thành Microsoft.JET.OLEDB.4.0

   và Excel 12.0 thành Excel 8.0
   Rất có thể file con bên trong là 2003
   Nên bạn sửa cụm sau trong code trên.

   & ".xlsx" &

   Thành

   & ".xls" &

   Reply
7. hands says:

   03/12/2022 at 9:26 am

   anh,
   em muốn lấy dữ lieu từ các file khác nhưng dữ lieu nằm rãi rác như A13, C56, D78,…
   thì mình sửa code sao anh?
   em cảm ơn anh trước nhiều nhiều!

   bạn bấm ngôi sao chạy code

   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é.

   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

   Reply
8. hands says:

   03/12/2022 at 9:29 am

   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!

   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 ý

   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

   http://www.giaiphapexcel.com/diendan/threads/t%E1%BB%95ng-h%E1%BB%A3p-d%E1%BB%AF-li%E1%BB%87u-t%E1%BB%AB-nhi%E1%BB%81u-file-excel-v%C3%A0o-1-file-kh%C3%B4ng-c%E1%BA%A7n-m%E1%BB%9F-file.84529/post-772413

   Reply
9. hands says:

   03/12/2022 at 9:33 am

   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.

   Bạn chạy mỗi code này. Còn code trong file tôi không sửa nha

   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

   http://www.giaiphapexcel.com/diendan/threads/t%E1%BB%95ng-h%E1%BB%A3p-d%E1%BB%AF-li%E1%BB%87u-t%E1%BB%AB-nhi%E1%BB%81u-file-excel-v%C3%A0o-1-file-kh%C3%B4ng-c%E1%BA%A7n-m%E1%BB%9F-file.84529/post-791713

   Reply
10. hands says:

    03/12/2022 at 9:35 am

    Xin chào Diễn Đàn,
    Em có 2 file cần gộp, nhưng theo bản code ban đầu từ thầy NDU thì khi em lấy data lần đầu ok, nhưng nếu em lấy data lần 2 thì file tổng lại không chép đè lên mà lại chép tiếp.
    Ví dụ: lần 1 em lấy CA1 có 2 dòng và CA2 có 2 dòng. Tức là file Master sẽ có 4 dòng.
    Lần 2 em lấy lại CA1 và CA2 thì file Master chép lại từ đầu nhưng bắt đầu từ dòng thứ 5, như vậy là em bị trùng thông tin.
    Thầy hoặc các bạn có cách nào fix giúp em với ạ.

    Tôi không thử "tình huống" với các file của bạn, tôi chỉ có thể "thêm 1 chút" code có sẵn (của người khác đã viết), Bạn chay thử có thể đạt yêu cầu của bạn. Nếu không thì chờ bạn khác xem giúp.
    Trong FILE TONG HOP, bạn sửa Sub Main() trong modMain như sau:

    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"
        Sheet1.Range("A8").Resize(1000, 26).ClearContents   '<============ Them dong nay'
        For Each FileItem In vFile
        aRes = Nothing
          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

    http://www.giaiphapexcel.com/diendan/threads/t%E1%BB%95ng-h%E1%BB%A3p-d%E1%BB%AF-li%E1%BB%87u-t%E1%BB%AB-nhi%E1%BB%81u-file-excel-v%C3%A0o-1-file-kh%C3%B4ng-c%E1%BA%A7n-m%E1%BB%9F-file.84529/post-939566

    Reply