Tổng hợp dữ liệu từ nhiều file excel theo từng ngày vào file excel đóng

Bình22222 · 23/9/19

Chào mọi người.

Nhờ mọi người giúp mình vấn đề gộp các file excel riêng lẻ vào 1 sheet trong file excel.
Mình đã lên các diễn đàn và youtube xem hướng dẫn dùng VBA giải quết cho vấn đề này, nhưng mình không làm được cho trường hợp của mình, rất mong được mọi người giúp đỡ.

Trong tháng mình có khoảng hơn 100 file excel ghi nhận báo cáo kiểm tra chất lượng sản phẩm, mỗi file có 4 sheet.
Mình cần gộp sheet tên "ket qua KT " ở các file excel khác nhau vào chung 1 sheet, dòng bắt đầu lấy dữ liệu là dòng 12.
Lưu ý trong file excel của mình:
- dòng 4 đến dòng 8 bị ẩn và có chứa công thức liên kết với các sheet trong file excel.
- vùng G12:L12 sẽ bị thay đổi dữ liệu theo từng file excel.
- số dòng chứa dữ liệu khác nhau với mỗi file excel khác nhau (dao động từ 30 tới 300 dòng).
- các file excel sẽ được cập nhật dữ liệu theo ngày.

Cám ơn mọi người và diễn đàn.

AutoReply · 24/9/19

VetMini đã viết:
Thôi bớt hy vọng đi. Nếu hai người này không giải quyết được thì ở đây không còn ai đủ sức cả.

Thực tế cho thấy anh VetMini đã đánh giá sai rồi nha ###@#!

phulien1902 · 24/9/19

Lê Hồng Minh83 đã viết:

Bạn thử cách này xem có nhanh hơn xíu nào không nhé
Lưu ý, bỏ chung File "Cập nhật" vào cùng folder chưa các file cần copy dữ liệu

Mã:

Function GetExcelConnection(ByVal Path As String, Optional ByVal Header As Boolean = True)
    Dim StrConn As String, ObjConn As Object, Pro As String, Ext As String
    Set ObjConn = CreateObject("ADODB.Connection")
    If Application.Version < 12 Then
        Pro = "Provider=Microsoft.JET.OLEDB.4.0;"
        Ext = ";Extended Properties=""Excel 8.0;"
    Else
        Pro = "Provider=Microsoft.ACE.OLEDB.12.0;"
        Ext = ";Extended Properties=""Excel 12.0;"
    End If
    StrConn = Pro & "Data Source=" & Path & Ext & "HDR=" & IIf(Header, "Yes", "No") & ";IMEX=1"";"
    ObjConn.Open StrConn
    Set GetExcelConnection = ObjConn
End Function

Sub Copy_DATA()
Dim ObjConn As Object, RS As Object, Files, arr()
Dim StrRequest As String, Path As String, i As Long, lr As Long

On Error Resume Next
Path = ThisWorkbook.Path
    With Sheets("tonghop")
    lr = .Range("DC1000").End(xlUp).Row
    arr = .Range("DC2:DC" & lr).Value
    .Range("A13:CZ60000").ClearContents
    .Range("A13").Value = "A1"
    For i = 1 To UBound(arr, 1)
        Files = arr(i, 1)
        Set RS = CreateObject("ADODB.Recordset")
        Set ObjConn = GetExcelConnection(Path & "\" & Files, 0)
        StrRequest = "SELECT * FROM [ket qua KT $A13:CZ1000]"
        RS.Open StrRequest, ObjConn, 3, 1
        Sheets("tonghop").Range("A65000").End(xlUp).Resize(1).CopyFromRecordset RS
        ObjConn.Close
        Next
        lr = .Range("A65000").End(xlUp).Row
        .Range("A" & lr + 1).Resize(10000, 200).ClearContents
        .Range("DC1:DC200").ClearContents
    End With
    Set RS = Nothing
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub
Sub Getname()
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Dim sh As Worksheet, fso As Object, fo As Folder, f As File, lr As Integer
    Set sh = ThisWorkbook.Sheets("tonghop")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fo = fso.GetFolder(ThisWorkbook.Path)
    sh.Range("DC1:DC1000").ClearContents
    For Each f In fo.Files
    lr = sh.Range("DC1000").End(xlUp).Row + 1
    sh.Range("DC" & lr).Value = f.Name
    Next
    Set fso = Nothing
    Call Copy_DATA
End Sub

Vì máy cơ quan đời thấp quá không kiểm tra được, bạn có thể chỉnh sửa Code cho phù hợp với Excel 2003?
Xin cảm ơn.

Bài đã được tự động gộp: 24/9/19

HieuCD đã viết:

Dùng thử code

Mã:

Sub ABC()
  Dim cn As Object, rs As Object
  Dim sFile, oFile, sh As Worksheet, eRow&
   
  Application.ScreenUpdating = False
  Set sh = Sheets("tonghop")
  eRow = sh.Range("A" & Rows.Count).End(xlUp).Row 'Dong cuoi, Xoa du lieu cu
  If eRow > 12 Then sh.Range("A13:CZ" & eRow).ClearContents 'Xoa du lieu cu

  sFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.xlsx),*.xls*", _
                                        Title:="Select File", MultiSelect:=True)
  If VarType(sFile) = vbBoolean Then MsgBox ("Chua chon File du lieu"): Exit Sub
  Set cn = CreateObject("adodb.connection")
  For Each oFile In sFile
    eRow = sh.Range("A" & Rows.Count).End(xlUp).Row
    cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & oFile & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
    Set rs = cn.Execute("select * from [ket qua KT $A13:CZ65000] where f1 is not null")
    eRow = sh.Range("A" & Rows.Count).End(xlUp).Row
    If eRow < 13 Then eRow = 13
    If Not rs.EOF Then sh.Range("A" & eRow + 1).CopyFromRecordset rs
    rs.Close:    cn.Close
  Next
  Set cn = Nothing: Set rs = Nothing
  Application.ScreenUpdating = True
End Sub

Anh có thể chỉnh sửa Code cho phù hợp với Excel 2003 được không?
Cảm ơn anh!

VetMini · 24/9/19

AutoReply đã viết:
Thực tế cho thấy anh VetMini đã đánh giá sai rồi nha

Mới 21 bài. Và bài #19, #20 đều là code lần đầu, chưa qua phần thử thách biến hoá của thớt.
Thống kê diễn đàn này cho biết rất ít bài lần đầu mà không bị vướng "...code chạy gần đúng rồi, nhưng mà..."

Mới vừa pót lên thì thấy bài #22. ###@#!

phulien1902 · 24/9/19

VetMini đã viết:
Ủa cơ quan bạn cho phép dùng máy để thử file vớ vẩn hở?

Em đang thử nghiệm với các File đó đây.

Bình22222 · 24/9/19

phulien1902 đã viết:
Vì máy cơ quan đời thấp quá không kiểm tra được, bạn có thể chỉnh sửa Code cho phù hợp với Excel 2003?
Xin cảm ơn.

Bài đã được tự động gộp: 24/9/19

Anh có thể chỉnh sửa Code cho phù hợp với Excel 2003 được không?
Cảm ơn anh!

Mình không biết gì nhiều về VBA, mọi người hướng dẫn mình copy paste phần nào thì mình làm theo, nên không biết sửa sao luôn.
Với lại file excel cơ quan mình dùng 2016 nên các file làm việc bị mặt định luôn 2016.

HieuCD · 24/9/19

phulien1902 đã viết:
Vì máy cơ quan đời thấp quá không kiểm tra được, bạn có thể chỉnh sửa Code cho phù hợp với Excel 2003?
Xin cảm ơn.

Bài đã được tự động gộp: 24/9/19

Anh có thể chỉnh sửa Code cho phù hợp với Excel 2003 được không?
Cảm ơn anh!

Copy lệnh trên diễn đàn chưa kiểm tra, Bạn kiểm tra lại chạy được không

Mã:

Sub ABC()
  Dim cn As Object, rs As Object
  Dim sFile, oFile, sh As Worksheet, eRow&
    
  Application.ScreenUpdating = False
  Set sh = Sheets("tonghop")
  eRow = sh.Range("A" & Rows.Count).End(xlUp).Row 'Dong cuoi, Xoa du lieu cu
  If eRow > 12 Then sh.Range("A13:CZ" & eRow).ClearContents 'Xoa du lieu cu
 
  sFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.xlsx),*.xls*", _
                                        Title:="Select File", MultiSelect:=True)
  If VarType(sFile) = vbBoolean Then MsgBox ("Chua chon File du lieu"): Exit Sub
  Set cn = CreateObject("adodb.connection")
  For Each oFile In sFile
    eRow = sh.Range("A" & Rows.Count).End(xlUp).Row
    If Val(Application.Version) < 12 Then
      cn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & oFile & ";Extended Properties=""Excel 8.0;HDR=No"";")
    Else
      cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & oFile & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
    End If
    Set rs = cn.Execute("select * from [ket qua KT $A13:CZ65000] where f1 is not null")
    eRow = sh.Range("A" & Rows.Count).End(xlUp).Row
    If eRow < 13 Then eRow = 13
    If Not rs.EOF Then sh.Range("A" & eRow + 1).CopyFromRecordset rs
    rs.Close:    cn.Close
  Next
  Set cn = Nothing: Set rs = Nothing
  Application.ScreenUpdating = True
End Sub

Bình22222 · 24/9/19

Lê Hồng Minh83 đã viết:

Bạn thử cách này xem có nhanh hơn xíu nào không nhé
Lưu ý, bỏ chung File "Cập nhật" vào cùng folder chưa các file cần copy dữ liệu

Mã:

Function GetExcelConnection(ByVal Path As String, Optional ByVal Header As Boolean = True)
    Dim StrConn As String, ObjConn As Object, Pro As String, Ext As String
    Set ObjConn = CreateObject("ADODB.Connection")
    If Application.Version < 12 Then
        Pro = "Provider=Microsoft.JET.OLEDB.4.0;"
        Ext = ";Extended Properties=""Excel 8.0;"
    Else
        Pro = "Provider=Microsoft.ACE.OLEDB.12.0;"
        Ext = ";Extended Properties=""Excel 12.0;"
    End If
    StrConn = Pro & "Data Source=" & Path & Ext & "HDR=" & IIf(Header, "Yes", "No") & ";IMEX=1"";"
    ObjConn.Open StrConn
    Set GetExcelConnection = ObjConn
End Function

Sub Copy_DATA()
Dim ObjConn As Object, RS As Object, Files, arr()
Dim StrRequest As String, Path As String, i As Long, lr As Long

On Error Resume Next
Path = ThisWorkbook.Path
    With Sheets("tonghop")
    lr = .Range("DC1000").End(xlUp).Row
    arr = .Range("DC2:DC" & lr).Value
    .Range("A13:CZ60000").ClearContents
    .Range("A13").Value = "A1"
    For i = 1 To UBound(arr, 1)
        Files = arr(i, 1)
        Set RS = CreateObject("ADODB.Recordset")
        Set ObjConn = GetExcelConnection(Path & "\" & Files, 0)
        StrRequest = "SELECT * FROM [ket qua KT $A13:CZ1000]"
        RS.Open StrRequest, ObjConn, 3, 1
        Sheets("tonghop").Range("A65000").End(xlUp).Resize(1).CopyFromRecordset RS
        ObjConn.Close
        Next
        lr = .Range("A65000").End(xlUp).Row
        .Range("A" & lr + 1).Resize(10000, 200).ClearContents
        .Range("DC1:DC200").ClearContents
    End With
    Set RS = Nothing
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub
Sub Getname()
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Dim sh As Worksheet, fso As Object, fo As Folder, f As File, lr As Integer
    Set sh = ThisWorkbook.Sheets("tonghop")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fo = fso.GetFolder(ThisWorkbook.Path)
    sh.Range("DC1:DC1000").ClearContents
    For Each f In fo.Files
    lr = sh.Range("DC1000").End(xlUp).Row + 1
    sh.Range("DC" & lr).Value = f.Name
    Next
    Set fso = Nothing
    Call Copy_DATA
End Sub

HieuCD đã viết:

Dùng thử code

Mã:

Sub ABC()
  Dim cn As Object, rs As Object
  Dim sFile, oFile, sh As Worksheet, eRow&
   
  Application.ScreenUpdating = False
  Set sh = Sheets("tonghop")
  eRow = sh.Range("A" & Rows.Count).End(xlUp).Row 'Dong cuoi, Xoa du lieu cu
  If eRow > 12 Then sh.Range("A13:CZ" & eRow).ClearContents 'Xoa du lieu cu

  sFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.xlsx),*.xls*", _
                                        Title:="Select File", MultiSelect:=True)
  If VarType(sFile) = vbBoolean Then MsgBox ("Chua chon File du lieu"): Exit Sub
  Set cn = CreateObject("adodb.connection")
  For Each oFile In sFile
    eRow = sh.Range("A" & Rows.Count).End(xlUp).Row
    cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & oFile & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
    Set rs = cn.Execute("select * from [ket qua KT $A13:CZ65000] where f1 is not null")
    eRow = sh.Range("A" & Rows.Count).End(xlUp).Row
    If eRow < 13 Then eRow = 13
    If Not rs.EOF Then sh.Range("A" & eRow + 1).CopyFromRecordset rs
    rs.Close:    cn.Close
  Next
  Set cn = Nothing: Set rs = Nothing
  Application.ScreenUpdating = True
End Sub

Cám ơn "Lê Hồng Minh83" và "HieuCD"

File của "Lê Hồng Minh83" khi chạy nhiều file thì gặp tình trạng bỏ dòng và bị bỏ file (có file copy được, có file không)

File của "HieuCD" không chạy được bạn ơi, excel báo lỗi "Cannot run macro excel" mặt dù mình có enable all macros.

Lê Hồng Minh83 · 24/9/19

Bình22222 đã viết:
File của "Lê Hồng Minh83" khi chạy nhiều file thì gặp tình trạng bỏ dòng và bị bỏ file (có file copy được, có file không)

Sao lại bỏ file nhỉ, cái Getname nó lấy tất tên file trong cùng 1 thư mục mà, bạn up lên mấy file bị bỏ đó xem sao

phulien1902 đã viết:
bạn có thể chỉnh sửa Code cho phù hợp với Excel 2003?

Cái Getname nó lấy tất file .xls, xlsx, xlsm, xlsb... mà bác. kiểm tra xem file đã được bật Microsoft Scripting Runtime trong Reference chưa nhé

phulien1902 · 24/9/19

Lê Hồng Minh83 đã viết:
Sao lại bỏ file nhỉ, cái Getname nó lấy tất tên file trong cùng 1 thư mục mà, bạn up lên mấy file bị bỏ đó xem sao

Cái Getname nó lấy tất file .xls, xlsx, xlsm, xlsb... mà bác. kiểm tra xem file đã được bật Microsoft Scripting Runtime trong Reference chưa nhé

Tất cả đã sẵn sàng, code không lỗi, vậy mà không cập nhật được dữ liệu. Tôi nghĩ phải sửa mấy dòng dưới đây?

PHP:

  If Application.Version < 12 Then
        Pro = "Provider=Microsoft.JET.OLEDB.4.0;"
        Ext = ";Extended Properties=""Excel 8.0;"
    Else
        Pro = "Provider=Microsoft.ACE.OLEDB.12.0;"
        Ext = ";Extended Properties=""Excel 12.0;"
    End If

Lê Hồng Minh83 · 24/9/19

phulien1902 đã viết:
Tất cả đã sẵn sàng, code không lỗi, vậy mà không cập nhật được dữ liệu. Tôi nghĩ phải sửa mấy dòng dưới đây?

PHP:

If Application.Version < 12 Then Pro = "Provider=Microsoft.JET.OLEDB.4.0;" Ext = ";Extended Properties=""Excel 8.0;" Else Pro = "Provider=Microsoft.ACE.OLEDB.12.0;" Ext = ";Extended Properties=""Excel 12.0;" End If

thử đổi
Pro = "Provider=Microsoft.ACE.OLEDB.12.0;"
Ext = ";Extended Properties=""Excel 12.0;"
thành
Pro = "Provider=Microsoft.ACE.OLEDB.12.0;"
Ext = ";Extended Properties=""Excel 8.0;"
mình không có excel 2003 để test nên ko biết thế nào

phulien1902 · 24/9/19

HieuCD đã viết:

Copy lệnh trên diễn đàn chưa kiểm tra, Bạn kiểm tra lại chạy được không

Mã:

Sub ABC()
  Dim cn As Object, rs As Object
  Dim sFile, oFile, sh As Worksheet, eRow&
   
  Application.ScreenUpdating = False
  Set sh = Sheets("tonghop")
  eRow = sh.Range("A" & Rows.Count).End(xlUp).Row 'Dong cuoi, Xoa du lieu cu
  If eRow > 12 Then sh.Range("A13:CZ" & eRow).ClearContents 'Xoa du lieu cu

  sFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.xlsx),*.xls*", _
                                        Title:="Select File", MultiSelect:=True)
  If VarType(sFile) = vbBoolean Then MsgBox ("Chua chon File du lieu"): Exit Sub
  Set cn = CreateObject("adodb.connection")
  For Each oFile In sFile
    eRow = sh.Range("A" & Rows.Count).End(xlUp).Row
    If Val(Application.Version) < 12 Then
      cn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & oFile & ";Extended Properties=""Excel 8.0;HDR=No"";")
    Else
      cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & oFile & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
    End If
    Set rs = cn.Execute("select * from [ket qua KT $A13:CZ65000] where f1 is not null")
    eRow = sh.Range("A" & Rows.Count).End(xlUp).Row
    If eRow < 13 Then eRow = 13
    If Not rs.EOF Then sh.Range("A" & eRow + 1).CopyFromRecordset rs
    rs.Close:    cn.Close
  Next
  Set cn = Nothing: Set rs = Nothing
  Application.ScreenUpdating = True
End Sub

Cảm ơn bác, Code chạy và cho kết quả đúng như ý muốn!

HieuCD · 24/9/19

Bình22222 đã viết:
Cám ơn "Lê Hồng Minh83" và "HieuCD"

File của "Lê Hồng Minh83" khi chạy nhiều file thì gặp tình trạng bỏ dòng và bị bỏ file (có file copy được, có file không)

File của "HieuCD" không chạy được bạn ơi, excel báo lỗi "Cannot run macro excel" mặt dù mình có enable all macros.

Mình quên chỉnh nút lệnh chạy code

Mã:

Sub ABC()
  Dim cn As Object, rs As Object
  Dim sFile, oFile, sh As Worksheet, eRow&
    
  Application.ScreenUpdating = False
  Set sh = Sheets("tonghop")
  eRow = sh.Range("A" & Rows.Count).End(xlUp).Row 'Dong cuoi, Xoa du lieu cu
  If eRow > 12 Then sh.Range("A13:CZ" & eRow).ClearContents 'Xoa du lieu cu
 
  sFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.xlsx),*.xls*", _
                                        Title:="Select File", MultiSelect:=True)
  If VarType(sFile) = vbBoolean Then MsgBox ("Chua chon File du lieu"): Exit Sub
  Set cn = CreateObject("adodb.connection")
  For Each oFile In sFile
    eRow = sh.Range("A" & Rows.Count).End(xlUp).Row
    If Val(Application.Version) < 12 Then
      cn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & oFile & ";Extended Properties=""Excel 8.0;HDR=No"";")
    Else
      cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & oFile & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
    End If
    Set rs = cn.Execute("select * from [ket qua KT $A13:CZ65000] where f1 is not null")
    eRow = sh.Range("A" & Rows.Count).End(xlUp).Row
    If eRow < 12 Then eRow = 12
    If Not rs.EOF Then sh.Range("A" & eRow + 1).CopyFromRecordset rs
    rs.Close:    cn.Close
  Next
  Set cn = Nothing: Set rs = Nothing
  Application.ScreenUpdating = True
End Sub

Bình22222 · 24/9/19

phulien1902 đã viết:
Tất cả đã sẵn sàng, code không lỗi, vậy mà không cập nhật được dữ liệu. Tôi nghĩ phải sửa mấy dòng dưới đây?

PHP:

If Application.Version < 12 Then Pro = "Provider=Microsoft.JET.OLEDB.4.0;" Ext = ";Extended Properties=""Excel 8.0;" Else Pro = "Provider=Microsoft.ACE.OLEDB.12.0;" Ext = ";Extended Properties=""Excel 12.0;" End If

Mình đã thử chạy lại file của "Lê Hồng Minh83" (không sửa code) code VBA đã gộp được hết tất cả các file trong folder, nhưng bị lỗi bỏ dòng, khi sửa lại code như gợi ý của “phulien1902” file vẫn chạy được nhưng cũng bị lỗi bỏ dòng như ban đầu.
Mình gửi file cho bạn dễ theo dõi (3 file 171 dòng khi gộp được chỉ được 169 dòng).

Bài đã được tự động gộp: 24/9/19

HieuCD đã viết:

Mình quên chỉnh nút lệnh chạy code

Mã:

Sub ABC()
  Dim cn As Object, rs As Object
  Dim sFile, oFile, sh As Worksheet, eRow&
  
  Application.ScreenUpdating = False
  Set sh = Sheets("tonghop")
  eRow = sh.Range("A" & Rows.Count).End(xlUp).Row 'Dong cuoi, Xoa du lieu cu
  If eRow > 12 Then sh.Range("A13:CZ" & eRow).ClearContents 'Xoa du lieu cu

  sFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.xlsx),*.xls*", _
                                        Title:="Select File", MultiSelect:=True)
  If VarType(sFile) = vbBoolean Then MsgBox ("Chua chon File du lieu"): Exit Sub
  Set cn = CreateObject("adodb.connection")
  For Each oFile In sFile
    eRow = sh.Range("A" & Rows.Count).End(xlUp).Row
    If Val(Application.Version) < 12 Then
      cn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & oFile & ";Extended Properties=""Excel 8.0;HDR=No"";")
    Else
      cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & oFile & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
    End If
    Set rs = cn.Execute("select * from [ket qua KT $A13:CZ65000] where f1 is not null")
    eRow = sh.Range("A" & Rows.Count).End(xlUp).Row
    If eRow < 12 Then eRow = 12
    If Not rs.EOF Then sh.Range("A" & eRow + 1).CopyFromRecordset rs
    rs.Close:    cn.Close
  Next
  Set cn = Nothing: Set rs = Nothing
  Application.ScreenUpdating = True
End Sub

Cám ơn "HieuCD".
File macro của bạn đã chạy được và không phát sinh lỗi gì hết.
Mình gửi file nén chứa kết quả cho mọi người tham khao.

Một lần nữa rất cám ơn các thành viên trong diễn đàn đã nhiệt tình giúp mình giải quyết vấn đề.

Lê Hồng Minh83 · 24/9/19

Bình22222 đã viết:
nhưng bị lỗi bỏ dòng

Cái này không phải lỗi bỏ dòng, mà do mình nhầm chút nên dữ liệu file sau chèn lên dòng cuối dữ liệu file trước đó
mình điều chỉnh lại code chút xíu (do tiêu đề bạn merge ô), bạn thích sử dụng cái nào thì dùng

Bình22222 · 24/9/19

Lê Hồng Minh83 đã viết:
Cái này không phải lỗi bỏ dòng, mà do mình nhầm chút nên dữ liệu file sau chèn lên dòng cuối dữ liệu file trước đó
mình điều chỉnh lại code chút xíu (do tiêu đề bạn merge ô), bạn thích sử dụng cái nào thì dùng

Rất OK giờ file đã chạy được rồi
Cám ơn "Lê Hồng Minh83".

HeSanbi · 24/9/19

Bạn muốn sử dụng ADO thì sử dụng code dưới đây, thêm số thứ tự cho dữ liệu.

Bạn đọc lại #8 để biết cách tự động chọn Thư mục. Ở #8 hôm trước đã sửa lại để tương thích với Excel 2003

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

JavaScript:

Sub MergeWorkbooks()

  Dim File, Files, TH As Worksheet
  Dim Arrs, Arr(), Total()
  Dim R&, C%, LC&, LR&, LRs&
  Const CR = 12, nWS = "TongHop"
  Application.ScreenUpdating = False
  On Error Resume Next
  Set TH = ThisWorkbook.Worksheets(nWS)
  If Err Then: Set TH = Application.Workbooks.Add: TH.Name = nWS
  Err.Clear
  LR = TH.Range("A" & Rows.Count).End(xlUp).Row

  If LR > CR Then TH.Range("A" & CR + 1 & ":CZ" & LR).ClearContents

  Files = Application.GetOpenFilename(FileFilter:="Excel Files (*.xlsx),*.xls*", _
                                        Title:="Select File", MultiSelect:=True)

  If Not IsArray(Files) Then Exit Sub

  #If EarlyBinding Then
    Dim CN As ADODB.Connection, RS As ADODB.Recordset
    Set CN = New ADODB.Connection
  #Else
    Dim CN As Object, RS As Object
    Set CN = CreateObject("ADODB.Connection")
  #End If

  For Each File In Files
    If Application.Version < 12 Then
      CN.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & File & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
    Else
      CN.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & File & ";Extended Properties=""Excel 8.0;HDR=No"";")
    End If
    Err.Clear
    Set RS = CN.Execute("select * from [ket qua KT $A" & CR + 1 & ":CZ" & Rows.Count & "] where f1 is not null")
    If Err.Number = 0 Then
      If Not RS.EOF Then
        Arrs = RS.GetRows
        If UBound(Arrs) > 0 And UBound(Arrs, 2) > 0 Then
          If LC = 0 Then LC = UBound(Arrs) + 1
          LR = UBound(Arrs, 2) + 1
          ReDim Preserve Arr(1 To LC, 1 To LR + LRs)
          For C = 1 To LC
            For R = 1 To LR
              Arr(C, R + LRs) = Arrs(C - 1, R - 1)
              If C = 1 Then K = K + 1: Arr(C, R + LRs) = K
            Next R
          Next C
          LRs = LRs + LR
        End If
      End If
    End If
    RS.Close: CN.Close
  Next
  If K > 0 Then
    ReDim Total(1 To K, 1 To LC)
    For R = 1 To K: For C = 1 To LC
          Total(R, C) = Arr(C, R)
    Next C, R
    TH.Range("A" & CR + 1).Resize(K, LC).Value = Total
  End If
  Set TH = Nothing
  Set CN = Nothing: Set RS = Nothing
  Application.ScreenUpdating = True
End Sub

Bình22222 · 24/9/19

Hiện tại mình có 1 trường hợp nữa sẵn tiện các bạn cho mình hỏi luôn trong chủ đề này nha.

Khi đến giai đoạn sản xuất cuối, các file excel kiểm tra chất lượng sẽ nằm ở các folder khác nhau (mỗi folder chứa 1 hoặc nhiều file excel tùy khách hàng), các folder này thì được chứa cùng 1 folder tổng (sản phẩm a).

Cho mình hỏi có thể gộp sheet đầu tiên của các file excel nằm ở các folder khác nhau (các folder này được chứa trong cùng 1 folder tổng) lại được không, hay có thể chuyển nhanh các file excel được chứa riêng lẻ đó về chung 1 folder để dùng VBA cho trường hợp các file excel nằm cùng folder.

Rất cám ơn mọi người!

HieuCD · 7/10/19

Bình22222 đã viết:
Hiện tại mình có 1 trường hợp nữa sẵn tiện các bạn cho mình hỏi luôn trong chủ đề này nha.

Khi đến giai đoạn sản xuất cuối, các file excel kiểm tra chất lượng sẽ nằm ở các folder khác nhau (mỗi folder chứa 1 hoặc nhiều file excel tùy khách hàng), các folder này thì được chứa cùng 1 folder tổng (sản phẩm a).

Cho mình hỏi có thể gộp sheet đầu tiên của các file excel nằm ở các folder khác nhau (các folder này được chứa trong cùng 1 folder tổng) lại được không, hay có thể chuyển nhanh các file excel được chứa riêng lẻ đó về chung 1 folder để dùng VBA cho trường hợp các file excel nằm cùng folder.

Rất cám ơn mọi người!

Chôm code của bạn @befaint
Chạy Sub Main

Mã:

Sub Main()
  Dim folder_path$, ex_path&, sFile, oFile, eRow&, i&
  Dim cn As Object, rs As Object, sh As Worksheet
  Const extension As String = "xls*"
 
  folder_path = GetPathFolder("")
  If Len(folder_path) = 0 Then Exit Sub
  arrSubFolder = GetSubFolders(folder_path)
  If IsArray(arrSubFolder) Then
    Application.ScreenUpdating = False
    Set sh = Sheets("tonghop")
    eRow = sh.Range("A" & Rows.Count).End(xlUp).Row 'Dong cuoi, Xoa du lieu cu
    If eRow > 12 Then sh.Range("A13:CZ" & eRow).ClearContents 'Xoa du lieu cu
      
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    For n = 1 To UBound(arrSubFolder)
      sFile = GetFilesInFolder(arrSubFolder(n), extension)
      If IsArray(sFile) Then
        For Each oFile In sFile
          If Val(Application.Version) < 12 Then
            cn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & oFile & ";Extended Properties=""Excel 8.0;HDR=No"";")
          Else
            cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & oFile & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
          End If
          Set rs = cn.Execute("select * from [ket qua KT $A13:CZ65000] where f1 is not null")
          eRow = sh.Range("A" & Rows.Count).End(xlUp).Row
          If eRow < 12 Then eRow = 12
          If Not rs.EOF Then sh.Range("A" & eRow + 1).CopyFromRecordset rs
          rs.Close:    cn.Close
        Next
      End If
    Next n
    Set cn = Nothing: Set rs = Nothing
    Application.ScreenUpdating = True
  End If
End Sub

Private Function GetPathFolder(ByVal pathFolder As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = pathFolder
        If .Show = -1 Then GetPathFolder = .SelectedItems(1)
    End With
End Function

Private Function GetSubFolders(ByVal pathFolder As String)
    Dim objFolder As Object, objSubFolders As Object, res, k&

    Set objSubFolders = CreateObject("Scripting.FileSystemObject").GetFolder(pathFolder).SubFolders
    num_folders = objSubFolders.Count
    If num_folders < 1 Then Exit Function
    ReDim res(1 To num_folders)
    For Each objFolder In objSubFolders
        k = k + 1
        res(k) = objFolder.path
    Next objFolder
    GetSubFolders = res
End Function

Private Function GetFilesInFolder(ByVal pathFolder As String, ByVal extensionFile As String) As Variant
    Dim FSo As Object, objFolder As Object, objFile As Object, res As Variant, i As Long, num_files As Long
    Dim wb_name As String, path
    wb_name = ThisWorkbook.FullName
    
    Set FSo = CreateObject("Scripting.FileSystemObject")
    Set objFolder = FSo.GetFolder(pathFolder)
    extensionFile = VBA.UCase$(extensionFile)
    num_files = objFolder.Files.Count
    If num_files < 1 Then Exit Function
    ReDim res(1 To num_files)
    
    For Each objFile In objFolder.Files
        If VBA.UCase$(FSo.GetExtensionName(objFile)) Like extensionFile Then
            path = objFile.path
            If path <> wb_name Then
                i = i + 1
                res(i) = path
            End If
         End If
    Next objFile
    GetFilesInFolder = res
End Function

Bình22222 · 7/10/19

HieuCD đã viết:

Dùng thử code

Mã:

Sub ABC()
  Dim cn As Object, rs As Object
  Dim sFile, oFile, sh As Worksheet, eRow&
  
  Application.ScreenUpdating = False
  Set sh = Sheets("tonghop")
  eRow = sh.Range("A" & Rows.Count).End(xlUp).Row 'Dong cuoi, Xoa du lieu cu
  If eRow > 12 Then sh.Range("A13:CZ" & eRow).ClearContents 'Xoa du lieu cu

  sFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.xlsx),*.xls*", _
                                        Title:="Select File", MultiSelect:=True)
  If VarType(sFile) = vbBoolean Then MsgBox ("Chua chon File du lieu"): Exit Sub
  Set cn = CreateObject("adodb.connection")
  For Each oFile In sFile
    eRow = sh.Range("A" & Rows.Count).End(xlUp).Row
    cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & oFile & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
    Set rs = cn.Execute("select * from [ket qua KT $A13:CZ65000] where f1 is not null")
    eRow = sh.Range("A" & Rows.Count).End(xlUp).Row
    If eRow < 13 Then eRow = 13
    If Not rs.EOF Then sh.Range("A" & eRow + 1).CopyFromRecordset rs
    rs.Close:    cn.Close
  Next
  Set cn = Nothing: Set rs = Nothing
  Application.ScreenUpdating = True
End Sub

Cảm ơn anh đã giúp đỡ.
Code chạy rất tốt cho file hiện tại, tuy nhiên khi em lấy code này chạy cho file khác có cấu trúc tương tự file cũ, chỉ khác là có chèn thêm 2 cột R7, R8 thì bị lỗi như hình.
Em gửi file và hình để mọi người tham khảo.

HieuCD · 7/10/19

Bình22222 đã viết:
Cảm ơn anh đã giúp đỡ.
Code chạy rất tốt cho file hiện tại, tuy nhiên khi em lấy code này chạy cho file khác có cấu trúc tương tự file cũ, chỉ khác là có chèn thêm 2 cột R7, R8 thì bị lỗi như hình.
Em gửi file và hình để mọi người tham khảo.
View attachment 226220

Trong thư mục có nhiều file hệ thống tự lưu, nên xóa các file nầy
Chỉnh lại Function GetFilesInFolder

Mã:

Private Function GetFilesInFolder(ByVal pathFolder As String, ByVal extensionFile As String) As Variant
    Dim FSo As Object, objFolder As Object, objFile As Object, res As Variant, i As Long
    Dim wb_name As String, path
    wb_name = ThisWorkbook.FullName
    
    Set FSo = CreateObject("Scripting.FileSystemObject")
    Set objFolder = FSo.GetFolder(pathFolder)
    extensionFile = VBA.UCase$(extensionFile)
    If objFolder.Files.Count < 1 Then Exit Function
    
    For Each objFile In objFolder.Files
        If VBA.UCase$(FSo.GetExtensionName(objFile)) Like extensionFile Then
            path = objFile.path
            If Left(objFile.Name, 1) <> "~" Then
                If path <> wb_name Then
                    i = i + 1
                    ReDim Preserve res(1 To i)
                    res(i) = path
                End If
            End If
         End If
    Next objFile
    GetFilesInFolder = res
End Function

Tổng hợp dữ liệu từ nhiều file excel theo từng ngày vào file excel đóng

Thành viên mới

File đính kèm

Thành viên tiêu biểu

GPE - My love

Ăn cùng góc phố

GPE - My love

Thành viên mới

Chuyên gia GPE

Thành viên mới

Thành viên tiêu biểu

GPE - My love

Thành viên tiêu biểu

GPE - My love

Chuyên gia GPE

File đính kèm

Thành viên mới

File đính kèm

Thành viên tiêu biểu

File đính kèm

Thành viên mới

Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨

Thành viên mới

File đính kèm

Chuyên gia GPE

Thành viên mới

File đính kèm

Chuyên gia GPE

Đếm ngược thời gian