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

Liên hệ QC
B

Bình22222

Thành viên mới
Tham gia
17/9/19
Bài viết
18
Được thích
2
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.
 

File đính kèm

  • File báo cáo.rar
    1.1 MB · Đọc: 27
Sắp xếp theo thời gian sắp xếp theo bầu chọn
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
Nhấp chuột vào đây để mở rộng...
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:

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
Nhấp chuột vào đây để mở rộng...
Anh có thể chỉnh sửa Code cho phù hợp với Excel 2003 được không?
Cảm ơn anh!
 
Upvote 0
AutoReply đã viết:
Thực tế cho thấy anh VetMini đã đánh giá sai rồi nha ###@#!
Nhấp chuột vào đây để mở rộng...
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. ###@#!
 
Upvote 0
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:


Anh có thể chỉnh sửa Code cho phù hợp với Excel 2003 được không?
Cảm ơn anh!
Nhấp chuột vào đây để mở rộng...

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.
 
Upvote 0
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:


Anh có thể chỉnh sửa Code cho phù hợp với Excel 2003 được không?
Cảm ơn anh!
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
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
Nhấp chuột vào đây để mở rộng...



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.
 
Upvote 0
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)
Nhấp chuột vào đây để mở rộ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?
Nhấp chuột vào đây để mở rộng...
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é
 
Upvote 0
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é
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
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 :)
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
Cảm ơn bác, Code chạy và cho kết quả đúng như ý muốn!
 
Upvote 0
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.
Nhấp chuột vào đây để mở rộng...
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
 

File đính kèm

  • CAP NHAT.xlsm
    22.8 KB · Đọc: 17
Upvote 0
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
Nhấp chuột vào đây để mở rộng...


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:

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
Nhấp chuột vào đây để mở rộng...


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 đề.
 

File đính kèm

  • File báo cáo gộp thành công.rar
    1.1 MB · Đọc: 17
Upvote 0
Bình22222 đã viết:
nhưng bị lỗi bỏ dòng
Nhấp chuột vào đây để mở rộ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 :)
 

File đính kèm

  • CAP NHAT.xls
    143.5 KB · Đọc: 14
Upvote 0
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 :)
Nhấp chuột vào đây để mở rộng...

Rất OK giờ file đã chạy được rồi
Cám ơn "Lê Hồng Minh83".
 
Upvote 0
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
 
Lần chỉnh sửa cuối:
Upvote 0
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!
 

File đính kèm

  • Sản phẩm A.rar
    2.8 MB · Đọc: 11
Upvote 0
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!
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...

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.
Sự cố.PNG
 

File đính kèm

  • File gop.rar
    308.1 KB · Đọc: 9
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
2 3
Trả lời
54
Đọc
689
ptm0412
ptm0412
K
Tính tổng có điều kiện
Trả lời
3
Đọc
47
HieuCD
H
BlankMan
Superlative Сasual Dating - Verified Females
Trả lời
0
Đọc
7
BlankMan
BlankMan
kyo
  • Suggestion
Bài viết: SAP Scripting – Excel và SAP (P2)
    • Thích
Trả lời
11
Đọc
8K
Tình nghĩa giang hồ
Tình nghĩa giang hồ
H
Kết nối vba với Database host (hiện tại đang làm host web)
Trả lời
4
Đọc
170
ongke0711
ongke0711
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom