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

Liên hệ QC MyVTV Add-ins

huynhphuong thcspt

Thành viên mới
Tham gia ngày
31 Tháng tám 2018
Bài viết
38
Được thích
9
Nhờ các bạn trên diễn đàn chỉnh lại (xem) dùm code sau. Mình không biết lỗi ở đâu mà cứ mỗi lần copy (dữ liệu) nhiều file vào 1 file thì 2 file đầu dữ liệu copy đúng, bất đầu từ file thứ 3 trở đi thì bị bỏ trống khoảng 4 dòng trở lên rồi mới copy dữ liệu vào. Chân thành cảm ơn.
CODE NHƯ SAU (sưu tầm trên điễn đàn):
Sub GopFileExcel()
'XOA DU LIEU TRUOC KHI TH

Sheets("DATA").Select
Range("A1:AZ1").EntireColumn.Delete
'KHAI BAO TH
Dim FilesToOpen
Dim x As Integer
Dim wb As Workbook
'LENH TH
On Error GoTo ErrHandler
Application.DisplayAlerts = False 'tat canh bao
Application.ScreenUpdating = False 'tat nhay man hinh
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="Microsoft Excel Files (*.xls), *.xls", MultiSelect:=True, Title:="Files to Merge")

If MsgBox("Ban co muon chac tong hop du lieu dia ban khong?", vbYesNo) = vbYes Then 'canh bao tong hop dia ban

If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "No Files were selected"
GoTo ExitHandler
End If

x = 1
While x <= UBound(FilesToOpen)
Set wb = Workbooks.Open(Filename:=FilesToOpen(x))

If x = 1 Then
wb.Sheets(1).UsedRange.Copy ThisWorkbook.Sheets(1).Range("A1")
Else
lr = ThisWorkbook.Sheets(1).UsedRange.Rows.Count
wb.Sheets(1).UsedRange.Offset(4).Copy ThisWorkbook.Sheets(1).Range("A" & lr + 1)
End If

wb.Close False
x = x + 1
Wend

ExitHandler:
Application.ScreenUpdating = True 'tat nhay man hinh
Application.DisplayAlerts = True 'tat canh bao
Set wb = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler

End If 'ket thuc canh bao tong hop dia ban
End Sub
 

File đính kèm

  • 1_nhapphieudieutra_2021_1A.xls
    457.5 KB · Đọc: 28
  • 2_nhapphieudieutra_2021_1B.xls
    471 KB · Đọc: 16
  • 3_nhapphieudieutra_2021_1C.xls
    473 KB · Đọc: 16
  • 4_nhapphieudieutra_2021_1D.xls
    463 KB · Đọc: 15
  • 5_nhapphieudieutra_2021_1E.xls
    430 KB · Đọc: 15
  • 6_nhapphieudieutra_2021_CS.xls
    403 KB · Đọc: 15
  • TONG HOP.xlsm
    1,012.1 KB · Đọc: 20

huynhphuong thcspt

Thành viên mới
Tham gia ngày
31 Tháng tám 2018
Bài viết
38
Được thích
9
Thử thay lr = ThisWorkbook.Sheets(1).UsedRange.Rows.Count
bằng lr = ThisWorkbook.Sheets(1).Range("C" & Rows.Count).End(xlUp).Row
Cảm ơn bạn đã hướng dẫn nhưng vẫn không được bạn ơi. Chỉ được 3 file đầu tiên sau đó nó bỏ 22 dòng trống rồi mới copy 3 file còn lại. Mong bạn chỉ dẫn thêm.
 

File đính kèm

  • TONG HOP.xlsm
    1,018.5 KB · Đọc: 9

Maika8008

Tích cực để lên đời
Tham gia ngày
12 Tháng sáu 2020
Bài viết
1,673
Được thích
1,762
Giới tính
Nam
Cảm ơn bạn đã hướng dẫn nhưng vẫn không được bạn ơi. Chỉ được 3 file đầu tiên sau đó nó bỏ 22 dòng trống rồi mới copy 3 file còn lại. Mong bạn chỉ dẫn thêm.
Thay wb.Sheets(1).UsedRange.Offset(4).Copy ThisWorkbook.Sheets(1).Range("A" & lr + 1)
Bằng wb.Sheets(1).Range("B5:AY" & wb.Sheets(1).Range("C" & Rows.Count).End(xlUp).Row).Copy ThisWorkbook.Sheets(1).Range("A" & lr + 1)
 

huynhphuong thcspt

Thành viên mới
Tham gia ngày
31 Tháng tám 2018
Bài viết
38
Được thích
9
Bạn thử xem lại dữ liệu file gốc xem thế nào.
Cảm ơn! Đúng rồi bạn ơi do dữ liệu gốc. Gửi lời xin lỗi bạn Maika8008.
Cứ mỗi lần chạy file thì hiện bảng thông báo Micosoft excel: Updata Don't updata Help làm sao để không hiện bảng thông báo này mỗi khi mở file ?
 

Hoàng Tuấn 868

Thành viên đăng ký hôm qua
Tham gia ngày
9 Tháng mười một 2019
Bài viết
1,840
Được thích
1,520

huynhphuong thcspt

Thành viên mới
Tham gia ngày
31 Tháng tám 2018
Bài viết
38
Được thích
9
Thay wb.Sheets(1).UsedRange.Offset(4).Copy ThisWorkbook.Sheets(1).Range("A" & lr + 1)
Bằng wb.Sheets(1).Range("B5:AY" & wb.Sheets(1).Range("C" & Rows.Count).End(xlUp).Row).Copy ThisWorkbook.Sheets(1).Range("A" & lr + 1)
Cảm ơn bạn đã hướng dẫn, mình xin sửa lại .range ("B5:AY" ..... bằng .range ("A5:AY" ...... thì dữ liệu khớp hơn.
Nhân đây nhờ bạn giúp mình xuất ngược từ file tổng hợp thành từng file tương ứng như ban đầu đã tổng hợp ( khi xuất cấu trúc file không thay đổi). Căn cứ vào cột địa chỉ ( cột N ) dựa vào 2 ký tự cuối. Ví dụ: 1A xuất ra địa bàn nhập liệu xóm 1A, 1B xuất ra địa bàn nhập liệu xóm 1B, ... như file mẫu mình đã úp lên. ( xuất từng file theo ý mình thì càng tốt, ví dụ muốn xuất địa bàn nhập liệu xóm 1E thì chỉ cho ra file thuộc xóm 1E, ...... ) Xin chân thành cảm ơn.
 

File đính kèm

  • TONG HOP.xlsm
    394.8 KB · Đọc: 13

Maika8008

Tích cực để lên đời
Tham gia ngày
12 Tháng sáu 2020
Bài viết
1,673
Được thích
1,762
Giới tính
Nam
Cảm ơn bạn đã hướng dẫn, mình xin sửa lại .range ("B5:AY" ..... bằng .range ("A5:AY" ...... thì dữ liệu khớp hơn.
Nhân đây nhờ bạn giúp mình xuất ngược từ file tổng hợp thành từng file tương ứng như ban đầu đã tổng hợp ( khi xuất cấu trúc file không thay đổi). Căn cứ vào cột địa chỉ ( cột N ) dựa vào 2 ký tự cuối. Ví dụ: 1A xuất ra địa bàn nhập liệu xóm 1A, 1B xuất ra địa bàn nhập liệu xóm 1B, ... như file mẫu mình đã úp lên. ( xuất từng file theo ý mình thì càng tốt, ví dụ muốn xuất địa bàn nhập liệu xóm 1E thì chỉ cho ra file thuộc xóm 1E, ...... ) Xin chân thành cảm ơn.
Điền thông tin ở A6, bấm nút ở sheet MENU để chạy.
 

File đính kèm

  • TONG HOP_huynhphuong thcspt.xlsm
    412.9 KB · Đọc: 23

huynhphuong thcspt

Thành viên mới
Tham gia ngày
31 Tháng tám 2018
Bài viết
38
Được thích
9
Điền thông tin ở A6, bấm nút ở sheet MENU để chạy.
Chào bạn Maika8008! khi nào bạn rảnh xem dùm mình code XLOP (nhập tên lớp cần xuất vào A12) có trong file đính kèm:
1. Khả năng mình có hạn nên tạo ra code XLOP hơi lòng vòng dẫn đến chương trình chạy chậm. Nhờ bạn xem chỉnh dùm.
2. Làm sao ở dòng cuối của danh sách vừa xuất hiện : ..............., ngày tháng năm
3. Tạo Sheet lớp vừa xuất thành 1 file excel riêng.
xin cảm ơn !
 

File đính kèm

  • TONG HOP_huynhphuong thcspt.xlsm
    1 MB · Đọc: 8

Maika8008

Tích cực để lên đời
Tham gia ngày
12 Tháng sáu 2020
Bài viết
1,673
Được thích
1,762
Giới tính
Nam
Chào bạn Maika8008! khi nào bạn rảnh xem dùm mình code XLOP (nhập tên lớp cần xuất vào A12) có trong file đính kèm:
1. Khả năng mình có hạn nên tạo ra code XLOP hơi lòng vòng dẫn đến chương trình chạy chậm. Nhờ bạn xem chỉnh dùm.
2. Làm sao ở dòng cuối của danh sách vừa xuất hiện : ..............., ngày tháng năm
3. Tạo Sheet lớp vừa xuất thành 1 file excel riêng.
xin cảm ơn !
Ngó vậy chứ hết hơi à! Tôi làm từ đầu chứ không sửa sang chi.
 

File đính kèm

  • TONG HOP_huynhphuong thcspt (1).xlsm
    1.1 MB · Đọc: 14

huynhphuong thcspt

Thành viên mới
Tham gia ngày
31 Tháng tám 2018
Bài viết
38
Được thích
9
Ngó vậy chứ hết hơi à! Tôi làm từ đầu chứ không sửa sang chi.
Quá hay bạn ơi, chương trình chạy nhanh hơn mình tưởng tượng đúng là chuyên gia về Vba Excel có khác. Chân thành cảm ơn.
khi chạy chương trình thì gặp lỗi như thế này mà mình chỉnh hoài không xong, nhờ bạn xem lại dùm nhé. Ví dụ cột(s) tên lớp mà tên lớp có dấu * hoặc có dấu / (những ký tự đặc biệt ( 1A*, 4B*, 7/1, 7/4,.... ) thì chương trình báo lỗi ở mã code sau " Sheets("DATA").Range("B1:AY4").Copy nws.Range("A1") ". Rất mong bạn gỡ rối ở chỗ này.
 

Maika8008

Tích cực để lên đời
Tham gia ngày
12 Tháng sáu 2020
Bài viết
1,673
Được thích
1,762
Giới tính
Nam
Quá hay bạn ơi, chương trình chạy nhanh hơn mình tưởng tượng đúng là chuyên gia về Vba Excel có khác. Chân thành cảm ơn.
khi chạy chương trình thì gặp lỗi như thế này mà mình chỉnh hoài không xong, nhờ bạn xem lại dùm nhé. Ví dụ cột(s) tên lớp mà tên lớp có dấu * hoặc có dấu / (những ký tự đặc biệt ( 1A*, 4B*, 7/1, 7/4,.... ) thì chương trình báo lỗi ở mã code sau " Sheets("DATA").Range("B1:AY4").Copy nws.Range("A1") ". Rất mong bạn gỡ rối ở chỗ này.
Lỗi nằm ở câu lệnh đặt tên cho sheet có ký tự đặc biệt nhưng bị bỏ qua bởi On Error Resume Next, đến sau câu lệnh On Error GoTo 0 thì mắc lỗi không có sheet đích nào để copy sang.

Do đó buộc bạn phải đặt tên khác đi hoặc viết code loại trừ ký tự đó đi (Loại kiểu nào thì tạm thời tôi chưa biết)
 

Maika8008

Tích cực để lên đời
Tham gia ngày
12 Tháng sáu 2020
Bài viết
1,673
Được thích
1,762
Giới tính
Nam
Lỗi nằm ở câu lệnh đặt tên cho sheet có ký tự đặc biệt nhưng bị bỏ qua bởi On Error Resume Next, đến sau câu lệnh On Error GoTo 0 thì mắc lỗi không có sheet đích nào để copy sang.

Do đó buộc bạn phải đặt tên khác đi hoặc viết code loại trừ ký tự đó đi (Loại kiểu nào thì tạm thời tôi chưa biết)
Bạn thay bằng file này, trong đó tôi đã thêm đoạn code thay bất kỳ ký tự đặc biệt nào thành dấu _ (gạch thấp)
 

File đính kèm

  • TONG HOP_huynhphuong thcspt (1).xlsm
    1 MB · Đọc: 18

huynhphuong thcspt

Thành viên mới
Tham gia ngày
31 Tháng tám 2018
Bài viết
38
Được thích
9
Bạn thay bằng file này, trong đó tôi đã thêm đoạn code thay bất kỳ ký tự đặc biệt nào thành dấu _ (gạch thấp)
Cảm ơn bạn nhiều. Chương trình chạy rất tốt chỉ có lưu ý nhỏ nhờ bạn giúp mình cho hoàn thiện hơn. Dữ liệu xuất ra ở cột tên lớp dữ liệu đổi thành ngày tháng năm (khó nhìn) bạn ơi, mong bạn hướng dẫn thêm.
 

Maika8008

Tích cực để lên đời
Tham gia ngày
12 Tháng sáu 2020
Bài viết
1,673
Được thích
1,762
Giới tính
Nam
Cảm ơn bạn nhiều. Chương trình chạy rất tốt chỉ có lưu ý nhỏ nhờ bạn giúp mình cho hoàn thiện hơn. Dữ liệu xuất ra ở cột tên lớp dữ liệu đổi thành ngày tháng năm (khó nhìn) bạn ơi, mong bạn hướng dẫn thêm.
Tìm đoạn này thêm dòng đậm vào nhé:
Worksheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) 'tao va dem worksheet moi o phia sau sheet hien tai
Set nws = ActiveSheet
nws.Range("R5:R" & 4 + k).NumberFormat = "@"
On Error Resume Next

Tiện thể sửa lại cột M thay cho cột N ở dòng (để ở N có làm giãn rộng cột N -> xấu):
nws.Range("N" & k + 6) = "..............., Ngày ..... Tháng ..... " & Left(Sheets("DATA").Range("A1"), 3) & " 20...."
 

huynhphuong thcspt

Thành viên mới
Tham gia ngày
31 Tháng tám 2018
Bài viết
38
Được thích
9
Tìm đoạn này thêm dòng đậm vào nhé:
Worksheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) 'tao va dem worksheet moi o phia sau sheet hien tai
Set nws = ActiveSheet
nws.Range("R5:R" & 4 + k).NumberFormat = "@"
On Error Resume Next

Tiện thể sửa lại cột M thay cho cột N ở dòng (để ở N có làm giãn rộng cột N -> xấu):
nws.Range("N" & k + 6) = "..............., Ngày ..... Tháng ..... " & Left(Sheets("DATA").Range("A1"), 3) & " 20...."
Rất cảm ơn bạn, sau khi thêm dòng tô đậm chương trình chạy rất Ok. Mình thêm 1 vài dòng lệnh cho dòng ngày tháng năm nhìn ok hơn (code hơi lòng vòng 1 tí ) mong bạn hướng dẫn thêm:
nws.Range("M" & k + 6) = "..............., Ngày ..... Tháng ..... " & Left(Sheets("DATA").Range("A1"), 3) & " 20...."
nws.Range("M" & k + 6).Font.Italic = True
nws.Range("M" & k + 6).HorizontalAlignment = xlCenter
nws.Range("M" & k + 7) = "NG" & ChrW(431) & ChrW(7900) & "I L" & ChrW(7852) & "P B" & ChrW(7842) & "NG"
nws.Range("M" & k + 7).Font.Bold = True
nws.Range("M" & k + 7).HorizontalAlignment = xlCenter
nws.Range("M" & k + 11) = "Nguy" & ChrW(7877) & "n Hoàng Ph" & ChrW(432) & ChrW(417) & "ng"
nws.Range("M" & k + 11).Font.Bold = True
nws.Range("M" & k + 11).HorizontalAlignment = xlCenter
 

File đính kèm

  • Screenshot (3).png
    Screenshot (3).png
    221.2 KB · Đọc: 9

Maika8008

Tích cực để lên đời
Tham gia ngày
12 Tháng sáu 2020
Bài viết
1,673
Được thích
1,762
Giới tính
Nam
Vậy thôi chứ chi đâu lòng vòng. Có chăng là dùng With để gọn chút thôi. Ví dụ:
nws.Range("M" & k + 7) = "NG" & ChrW(431) & ChrW(7900) & "I L" & ChrW(7852) & "P B" & ChrW(7842) & "NG"
nws.Range("M" & k + 7).Font.Bold = True
nws.Range("M" & k + 7).HorizontalAlignment = xlCenter

thì viết lại thành:
With nws.Range("M" & k + 7)
.Value = "NG" & ChrW(431) & ChrW(7900) & "I L" & ChrW(7852) & "P B" & ChrW(7842) & "NG"
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
 

huynhphuong thcspt

Thành viên mới
Tham gia ngày
31 Tháng tám 2018
Bài viết
38
Được thích
9
Vậy thôi chứ chi đâu lòng vòng. Có chăng là dùng With để gọn chút thôi. Ví dụ:
nws.Range("M" & k + 7) = "NG" & ChrW(431) & ChrW(7900) & "I L" & ChrW(7852) & "P B" & ChrW(7842) & "NG"
nws.Range("M" & k + 7).Font.Bold = True
nws.Range("M" & k + 7).HorizontalAlignment = xlCenter

thì viết lại thành:
With nws.Range("M" & k + 7)
.Value = "NG" & ChrW(431) & ChrW(7900) & "I L" & ChrW(7852) & "P B" & ChrW(7842) & "NG"
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
Chào bạn MaiKa8008, cuối tuần chúc bạn sức khỏe và hạnh phúc. Mong bạn giúp mình thêm 1 vấn đề nữa là xuất danh sách với nhiều điều kiện. Nội dung diễn giải ở file đính kèm. chân thành cảm ơn bạn.
 

File đính kèm

  • TONG HOP_huynhphuong thcspt (2).xlsm
    1.1 MB · Đọc: 7
Top Bottom