Chào các anh chị, hiện tại em đang có một trường hợp cần phải tổng hợp dữ liệu từ nhiều file Excel khác nhau nhưng có cấu trúc giống nhau vào cùng 1 file report. Trước khi đăng bài, em có search và tìm hiểu bài
đăng "Tổng hợp dữ liệu từ nhiều file excel vào 1 file không cần mở file" và search từ khóa trên Google để tìm đọc và làm theo, tuy nhiên vẫn chưa thành công vì chưa hiểu rõ và có thêm một số điều kiện khác. Vậy kính mong các anh, các chị hỗ trợ giúp em trường hợp này.
Em có file Report Consolidation.xlsx là file master tổng hợp với các sheet từ "01" --->"99" được để chung thư mục với 2 file data là "casher_*.xlsx" và "Payment_*.xlsx" ( đuôi * tên file thay đổi) File Report này yêu cầu lấy data từ file "casher_*.xlsx" và từ file "Payment_*.xlsx". 1. Copy 2 file data tên là "casher_*.xlsx" và "Payment_*.xlsx" chung thư mục với file Report 2. Ấn Get Data, +tự động copy value dữ liệu vùng A4:J20 sheet1 của file
"Cash_*.xlsx" vào vùng C9:L25 của sheet 01 file Report +tự động copy value dữ liệu vùng A2:G5 sheet1 của file "Payment_*.xlsx" vào vùng D37:J41 của sheet 01 file Report (trường hợp có n file casher_* hoặc payment_* ở thư mục chung thì hiện hộp thoại báo báo xóa đi chỉ để lại 1 file, hoặc lựa 1 trong n file đó) 3. Xóa file data cũ đi, copy file data mới vào thư mục Vào sheet 02 của file Report, nhấn Get Data lặp lại copy như trên. Tương tự sheet 03, 04....
Mẫu file em có để ở file đính kèm ạ Rất mong nhận được sự hỗ trợ của anh chị. Em xin chân thành cảm ơn và mời anh chị cafe học hỏi ạ. View attachment 222877
Mã: Sub GopData()
Dim FSo As Object, cn As Object, n As Long
Dim iPath$, ShName$, FileName$, ShRng$, fName1$, RngAddress1$, fName2$, RngAddress2$
iPath = ThisWorkbook.Path & "\"
ShName = "Sheet1"
fName1 = "casher_": RngAddress1 = "$A4:J20"
fName2 = "Payment_": RngAddress2 = "$A2:G11"
Set FSo = CreateObject("Scripting.FileSystemObject")
Set cn = CreateObject("ADODB.Connection")
For n = 1 To ThisWorkbook.Sheets.Count
FileName = iPath & fName1 & Sheets(n).Name & ".xlsx"
If FSo.FileExists(FileName) Then
ShRng = ShName & RngAddress1
On Error Resume Next
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";Extended Properties=""Excel 12.0;HDR=No"";"
sqlStr = "Select * From [" & ShRng & "] where f2 is not null"
Sheets(n).Range("C9").CopyFromRecordset cn.Execute(sqlStr)
cn.Close
On Error GoTo 0
End If
FileName = iPath & fName2 & Sheets(n).Name & ".xlsx"
If FSo.FileExists(FileName) Then
ShRng = ShName & RngAddress2
On Error Resume Next
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";Extended Properties=""Excel 12.0;HDR=No"";"
sqlStr = "Select * From [" & ShRng & "] where f2 is not null"
a = Err.Number
Sheets(n).Range("D37").CopyFromRecordset cn.Execute(sqlStr)
cn.Close
On Error GoTo 0
End If
Next n
Set cn = Nothing: Set FSo = Nothing
End Sub
Mã: Sub GopData()
Dim FSo As Object, cn As Object, n As Long
Dim iPath$, ShName$, FileName$, ShRng$, fName1$, RngAddress1$, fName2$, RngAddress2$
iPath = ThisWorkbook.Path & "\"
ShName = "Sheet1"
fName1 = "casher_": RngAddress1 = "$A4:J20"
fName2 = "Payment_": RngAddress2 = "$A2:G11"
Set FSo = CreateObject("Scripting.FileSystemObject")
Set cn = CreateObject("ADODB.Connection")
For n = 1 To ThisWorkbook.Sheets.Count
FileName = iPath & fName1 & Sheets(n).Name & ".xlsx"
If FSo.FileExists(FileName) Then
ShRng = ShName & RngAddress1
On Error Resume Next
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";Extended Properties=""Excel 12.0;HDR=No"";"
sqlStr = "Select * From [" & ShRng & "] where f2 is not null"
Sheets(n).Range("C9").CopyFromRecordset cn.Execute(sqlStr)
cn.Close
On Error GoTo 0
End If
FileName = iPath & fName2 & Sheets(n).Name & ".xlsx"
If FSo.FileExists(FileName) Then
ShRng = ShName & RngAddress2
On Error Resume Next
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";Extended Properties=""Excel 12.0;HDR=No"";"
sqlStr = "Select * From [" & ShRng & "] where f2 is not null"
a = Err.Number
Sheets(n).Range("D37").CopyFromRecordset cn.Execute(sqlStr)
cn.Close
On Error GoTo 0
End If
Next n
Set cn = Nothing: Set FSo = Nothing
End Sub
Trước tiên, em xin chân thành cảm ơn anh @HieuCD đã hỗ trợ em ạ. Mã
code trên rất hiệu quả, song em bị mắc ở file data anh Hiếu ạ. Em có trình bày 2 file data là "casher_*.xlsx" và "Payment_*.xlsx" ( đuôi * thay đổi liên tục) Ví dụ Payment_01, casher_01; casher_02, Payment_02 ; Payment_03 casher_03; tương ứng với sheet 01, 02, 03 trong file Report ạ Thực tế là phần đuôi theo đổi theo ngày tải xuống như Payment_20190801.xlsx, casher_20190803.xlsx ==>data vào sheet 01 file
report Payment_20190804.xlsx, casher_20190805 (1).xlsx ==> data vào sheet 02 file report (trường hợp có n file casher_* hoặc payment_* ở thư mục chung thì hiện hộp thoại báo báo xóa đi chỉ để lại 1 file, hoặc lựa 1 trong n file đó)
Trước tiên, em xin chân thành cảm ơn anh @HieuCD đã hỗ trợ em ạ. Mã code trên rất hiệu quả, song em bị mắc ở file data anh Hiếu
ạ. Em có trình bày 2 file data là "casher_*.xlsx" và "Payment_*.xlsx" ( đuôi * thay đổi liên tục) Ví dụ Payment_01, casher_01; casher_02, Payment_02 ; Payment_03 casher_03; tương ứng với sheet 01, 02, 03 trong file Report ạ Thực tế là phần đuôi theo đổi theo ngày tải xuống như Payment_20190801.xlsx, casher_20190803.xlsx ==>data vào sheet 01 file report Payment_20190804.xlsx, casher_20190805
(1).xlsx ==> data vào sheet 02 file report (trường hợp có n file casher_* hoặc payment_* ở thư mục chung thì hiện hộp thoại báo báo xóa đi chỉ để lại 1 file, hoặc lựa 1 trong n file đó)
" Thực tế là phần đuôi theo đổi theo ngày tải xuống như Payment_20190801.xlsx, casher_20190803.xlsx ==>data vào sheet 01 file report Payment_20190804.xlsx, casher_20190805 (1).xlsx ==> data vào sheet 02 file report" Làm
sao biết đuôi nào vào sheet nào?
" Thực tế là phần đuôi theo đổi theo ngày tải xuống như Payment_20190801.xlsx, casher_20190803.xlsx ==>data vào sheet 01 file report Payment_20190804.xlsx, casher_20190805 (1).xlsx ==> data vào sheet 02 file report" Làm sao biết đuôi nào vào sheet
nào?
Dạ, thực tế em chỉ copy 1 file payment_* và 1 file casher_* vào thư mục chung file Report, gộp data xong sẽ xóa file data cũ luôn ạ Với sheet 02 thì em sẽ copy file data mới vào thư mục đó và gộp tương tự ạ Vậy nên em có trình bày trường hợp có >=2 file casher_* hoặc >=2 file payment_* ở thư mục chung thì hiện hộp thoại báo báo xóa đi chỉ để lại 1 file, hoặc lựa 1 trong n file đó.
" Thực tế là phần đuôi theo đổi theo ngày tải xuống như Payment_20190801.xlsx, casher_20190803.xlsx ==>data vào sheet 01 file report Payment_20190804.xlsx, casher_20190805 (1).xlsx ==> data vào sheet 02 file report" Làm sao biết đuôi nào vào sheet
nào?
Dạ, thực tế file data của em name Sheet mặc định là "Sheet 1" Em đã sửa ShName thêm khoảng trắng giữa "Sheet" và "1", nhưng khi cho chạy lại macro code lại không chạy. Mã: iPath = ThisWorkbook.Path & "\"
ShName = "Sheet 1"
fName1 = "casher_":
Trường hợp theo code cũ thì phải bật file đổi từ "Sheet 1" thành "Sheet1" thì lại ok. Mong bác HieuCD chỉ giáo ạ
Dạ, thực tế file data của em name Sheet mặc định là "Sheet 1" Em đã sửa ShName thêm khoảng trắng giữa "Sheet" và "1", nhưng khi cho chạy lại macro code lại không chạy. Mã: iPath = ThisWorkbook.Path & "\"
ShName = "Sheet 1"
fName1 = "casher_":
Trường hợp theo code cũ thì phải bật file đổi từ "Sheet
1" thành "Sheet1" thì lại ok. Mong bác HieuCD chỉ giáo ạ Tại sao phải copy rồi lại Xóa File? Code chọn trực tiếp File dữ liệu, Mã: Sub GopData()
Dim fd As Object, cn As Object, S
Dim iPath$, ShName$, FileName, ShRng$
Dim casher_Name$, casher_Address$, Payment_Name$, Payment_Address$
Dim casher_Bln As Boolean, Payment_Bln As Boolean
iPath = ThisWorkbook.Path & "\"
ShName = "Sheet 1" 'Ten cac sheet du lieu
casher_Name = "casher_": casher_Address = "$A4:J20"
Payment_Name = "Payment_": Payment_Address = "$A2:G11"
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = True
If .Show = -1 Then
Set tmp = .SelectedItems
Else
MsgBox ("Chua chon File"): Set fd = Nothing: Exit Sub
End If
End With
Set cn = CreateObject("ADODB.Connection")
For Each FileName In tmp
S = Split(FileName, "\")
If casher_Bln = False Then
If S(UBound(S)) Like casher_Name & "*" Then
ShRng = ShName & casher_Address
Call KetQua(cn, FileName, ShRng, "C9")
casher_Bln = True
End If
End If
If Payment_Bln = False Then
If S(UBound(S)) Like Payment_Name & "*" Then
ShRng = ShName & Payment_Address
Call KetQua(cn, FileName, ShRng, "D37")
Payment_Bln = True
End If
End If
If casher_Bln And Payment_Bln Then Exit For
Next
Set fd = Nothing: Set cn = Nothing
End Sub
Private Sub KetQua(ByRef cn, ByVal FileName$, ByVal ShRng$, ByVal RngResul$)
On Error Resume Next
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";Extended Properties=""Excel 12.0;HDR=No"";"
Range(RngResul).CopyFromRecordset cn.Execute("Select * From [" & ShRng & "]")
cn.Close
On Error GoTo 0
End Sub
không xóa file đã dùng. Nhấn phím Ctrl để chọn nhiều File
Tại sao phải copy rồi lại Xóa File? Code chọn trực tiếp File dữ liệu, Mã: Sub GopData()
Dim fd As Object, cn As Object, S
Dim iPath$, ShName$, FileName, ShRng$
Dim casher_Name$, casher_Address$, Payment_Name$, Payment_Address$
Dim casher_Bln As Boolean, Payment_Bln As Boolean
iPath = ThisWorkbook.Path & "\"
ShName = "Sheet 1" 'Ten cac sheet du lieu
casher_Name = "casher_": casher_Address = "$A4:J20"
Payment_Name = "Payment_": Payment_Address = "$A2:G11"
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = True
If .Show = -1 Then
Set tmp = .SelectedItems
Else
MsgBox ("Chua chon File"): Set fd = Nothing: Exit Sub
End If
End With
Set cn = CreateObject("ADODB.Connection")
For Each FileName In tmp
S = Split(FileName, "\")
If casher_Bln = False Then
If S(UBound(S)) Like casher_Name & "*" Then
ShRng = ShName & casher_Address
Call KetQua(cn, FileName, ShRng, "C9")
casher_Bln = True
End If
End If
If Payment_Bln = False Then
If S(UBound(S)) Like Payment_Name & "*" Then
ShRng = ShName & Payment_Address
Call KetQua(cn, FileName, ShRng, "D37")
Payment_Bln = True
End If
End If
If casher_Bln And Payment_Bln Then Exit For
Next
Set fd = Nothing: Set cn = Nothing
End Sub
Private Sub KetQua(ByRef cn, ByVal FileName$, ByVal ShRng$, ByVal RngResul$)
On Error Resume Next
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";Extended Properties=""Excel 12.0;HDR=No"";"
Range(RngResul).CopyFromRecordset cn.Execute("Select * From [" & ShRng & "]")
cn.Close
On Error GoTo 0
End Sub
không xóa file đã dùng. Nhấn phím Ctrl để chọn nhiều File Tại sao phải copy rồi lại Xóa File? Code chọn trực tiếp File dữ liệu, Mã: Sub GopData()
Dim fd As Object, cn As Object, S
Dim iPath$, ShName$, FileName, ShRng$
Dim casher_Name$, casher_Address$, Payment_Name$, Payment_Address$
Dim casher_Bln As Boolean, Payment_Bln As Boolean
iPath = ThisWorkbook.Path & "\"
ShName = "Sheet 1" 'Ten cac sheet du lieu
casher_Name = "casher_": casher_Address = "$A4:J20"
Payment_Name = "Payment_": Payment_Address = "$A2:G11"
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = True
If .Show = -1 Then
Set tmp = .SelectedItems
Else
MsgBox ("Chua chon File"): Set fd = Nothing: Exit Sub
End If
End With
Set cn = CreateObject("ADODB.Connection")
For Each FileName In tmp
S = Split(FileName, "\")
If casher_Bln = False Then
If S(UBound(S)) Like casher_Name & "*" Then
ShRng = ShName & casher_Address
Call KetQua(cn, FileName, ShRng, "C9")
casher_Bln = True
End If
End If
If Payment_Bln = False Then
If S(UBound(S)) Like Payment_Name & "*" Then
ShRng = ShName & Payment_Address
Call KetQua(cn, FileName, ShRng, "D37")
Payment_Bln = True
End If
End If
If casher_Bln And Payment_Bln Then Exit For
Next
Set fd = Nothing: Set cn = Nothing
End Sub
Private Sub KetQua(ByRef cn, ByVal FileName$, ByVal ShRng$, ByVal RngResul$)
On Error Resume Next
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";Extended Properties=""Excel 12.0;HDR=No"";"
Range(RngResul).CopyFromRecordset cn.Execute("Select * From [" & ShRng & "]")
cn.Close
On Error GoTo 0
End Sub
không xóa file đã dùng. Nhấn phím Ctrl để chọn nhiều File
Cám ơn anh @HieuCD Code hoạt động thành công ạ. Song em bị mắc là tải file từ
hệ thống xuống thì rồi chạy thì vẫn không nhận data. Phải bật file data lên can thiệp tên sheet thêm vài ký tự rồi xóa đi rồi Save lại thì lại hoạt động. Ví dụ. Em tải file data về, bật lên sửa name "Sheet 1" bằng cách thêm/xóa bất kỳ ký tự gì "Sheet 1234"rồi undo thao tác về "Sheet 1", Save lại. Chạy vba file report thì ok. Em chưa xác định được lỗi từ đâu. Có cách đổi cách nhận diện name Sheet thành code Sheet không ạ, vì file data e tải về đúng 1 sheet tên như trên thôi ạ.
Cám ơn anh @HieuCD Code hoạt động thành công ạ. Song em bị mắc là tải file từ hệ thống xuống thì rồi chạy thì vẫn không
nhận data. Phải bật file data lên can thiệp tên sheet thêm vài ký tự rồi xóa đi rồi Save lại thì lại hoạt động. Ví dụ. Em tải file data về, bật lên sửa name "Sheet 1" bằng cách thêm/xóa bất kỳ ký tự gì "Sheet 1234"rồi undo thao tác về "Sheet 1", Save lại. Chạy vba file report thì ok. Em chưa xác định được lỗi từ đâu. Có cách đổi cách nhận diện name Sheet thành code Sheet không ạ, vì file data e tải về đúng 1 sheet tên như trên thôi ạ.
Bạn gởi các file
data xuất từ phần mềm để mình kiểm tra tên sheet, dữ liệu có thể xóa cho nhẹ file
Bạn gởi các file data xuất từ phần mềm để mình kiểm tra tên sheet, dữ liệu có thể xóa cho nhẹ file
Dạ, ok anh. Em gửi anh file data ạ. Anh kiểm tra giúp em. Em open file data, thêm, xóa rồi SAVE lại thì Report gộp data được. Còn không thao tác thì ko chạy ạ.
-
File Data.zip 90.2 KB · Đọc: 14
Dạ, ok anh. Em gửi anh file data ạ. Anh kiểm tra giúp em. Em open file data, thêm, xóa rồi SAVE lại thì Report gộp data được. Còn không thao tác thì ko chạy ạ.
Phần mềm xuất file data bị lổi định dạng nên ADO không mở được file
Phần mềm xuất file data bị lổi định dạng nên ADO không mở được file
Dạ, vậy không có cách nào khác để chạy VBA được ạ
Dạ, vậy không có cách nào khác để chạy VBA được ạ
Chỉnh địa chỉ vùng copy cho phù hợp Mã: Sub GopData()
Dim fd As Object, wb As Workbook, tmp, cRng As Range, pRng As Range, S
Dim ShName$, FileName, ShRng$
Dim casher_Name$, casher_Address$, Payment_Name$, Payment_Address$
Dim casher_Bln As Boolean, Payment_Bln As Boolean
casher_Name = "Casher_": casher_Address = "A4:J20"
Payment_Name = "Payment_": Payment_Address = "A4:G13"
Set cRng = Range("C9")
Set pRng = Range("D37")
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = True
If .Show = -1 Then
Set tmp = .SelectedItems
Else
MsgBox ("Chua chon File"): Set fd = Nothing: Exit Sub
End If
End With
Application.EnableEvents = False
Application.ScreenUpdating = False
For Each FileName In tmp
S = Split(FileName, "\")
If casher_Bln = False Then
If S(UBound(S)) Like casher_Name & "*" Then
Set wb = Workbooks.Open(FileName, False, True)
Range(casher_Address).Copy cRng
casher_Bln = True
wb.Close fals
End If
End If
If Payment_Bln = False Then
If S(UBound(S)) Like Payment_Name & "*" Then
Set wb = Workbooks.Open(FileName, False, True)
Range(Payment_Address).Copy pRng
Payment_Bln = True
wb.Close fals
End If
End If
If casher_Bln And Payment_Bln Then Exit For
Next
Set fd = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Cũng với bài toán giống như trên, nhưng file data của mình có nhiều sheet, mình muốn chọn 1 sheet thì có cách nào ko anh @HieuCD ??
Cũng với bài toán giống như trên, nhưng file data của mình có nhiều sheet, mình muốn chọn 1 sheet thì có cách nào ko anh @HieuCD
??
Hình như có vài cách |