VBA Kết hợp nhiều tệp Excel vào một sổ làm việc

Hướng dẫn này sẽ chỉ cho bạn cách kết hợp nhiều tệp Excel vào một sổ làm việc trong VBA

Tạo một sổ làm việc từ một số sổ làm việc bằng VBA yêu cầu một số bước phải được thực hiện theo.

• Bạn cần chọn các sổ làm việc mà bạn muốn có dữ liệu nguồn - các tệp Nguồn.
• Bạn cần chọn hoặc tạo sổ làm việc mà bạn muốn đặt dữ liệu - tệp Đích.
• Bạn cần chọn các trang tính từ các tệp Nguồn mà bạn yêu cầu.
• Bạn cần cho mã biết vị trí đặt dữ liệu trong tệp Đích.

Kết hợp tất cả các Trang tính từ tất cả các Sổ làm việc Mở sang một Sổ làm việc Mới dưới dạng Trang tính Cá nhân

Trong đoạn mã dưới đây, các tệp bạn cần sao chép thông tin cần mở vì Excel sẽ lặp qua các tệp đang mở và sao chép thông tin vào một sổ làm việc mới. Mã được đặt trong Sổ làm việc Macro Cá nhân.

Các tệp này là Tệp Excel DUY NHẤT nên mở.

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647

Sub CombineMultipleFiles ()Lỗi GoTo eh'khai báo các biến để giữ các đối tượng được yêu cầuDim wbDestination As WorkbookDim wbSource As WorkbookDim wsSource As WorksheetDim wb As WorkbookDim sh As WorksheetDim strSheetName thành chuỗiDim strDestName As String'tắt cập nhật màn hình để tăng tốc mọi thứApplication.ScreenUpdating = Sai'đầu tiên hãy tạo sổ làm việc đích mớiĐặt wbDestination = Workbooks.Add'lấy tên của sổ làm việc mới để bạn loại trừ nó khỏi vòng lặp bên dướistrDestName = wbDestination.Name'bây giờ lặp qua từng sổ làm việc đang mở để lấy dữ liệu nhưng loại trừ sách mới của bạn hoặc sổ làm việc Macro Cá nhânĐối với mỗi wb trong ứng dụng.Nếu wb.Name strDestName Và wb.Name "PERSONAL.XLSB" ThìĐặt wbSource = wbĐối với mỗi sh Trong wbSource.Worksheetssh.Copy After: = Workbooks (strDestName) .Sheets (1)Tiếp theo shKết thúc nếuTuần tiếp theo'bây giờ đóng tất cả các tệp đang mở ngoại trừ tệp mới và sổ làm việc macro Cá nhân.Đối với mỗi wb trong ứng dụng.Nếu wb.Name strDestName Và wb.Name "PERSONAL.XLSB" Thìwb. Đóng SaiKết thúc nếuTuần tiếp theo'xóa trang tính khỏi sổ làm việc đíchApplication.DisplayAlerts = FalseTrang tính ("Trang 1"). XóaApplication.DisplayAlerts = True'dọn dẹp các đối tượng để giải phóng bộ nhớĐặt wbDestination = Không có gìĐặt wbSource = Không có gìĐặt wsSource = Không có gìĐặt wb = Không có gì'bật cập nhật màn hình khi hoàn tấtApplication.ScreenUpdating = SaiThoát SubHở:MsgBox Err.DescriptionKết thúc Sub

Bấm vào hộp thoại Macro để chạy quy trình từ màn hình Excel của bạn.

Tệp kết hợp của bạn bây giờ sẽ được hiển thị.

Mã này đã lặp qua từng tệp và sao chép trang tính vào một tệp mới. Nếu bất kỳ tệp nào của bạn có nhiều hơn một trang tính - nó cũng sẽ sao chép những trang tính đó - bao gồm cả những trang tính không có gì trên đó!

Kết hợp tất cả các Trang tính từ tất cả các Sổ làm việc đang Mở thành một Trang tính duy nhất trong một Sổ làm việc Mới

Quy trình dưới đây kết hợp thông tin từ tất cả các trang tính trong tất cả các sổ làm việc đang mở thành một trang tính trong một sổ làm việc mới được tạo.

Thông tin từ mỗi trang tính được dán vào trang tính đích tại hàng được sử dụng cuối cùng trên trang tính.

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869

Sub CombineMultipleSheets ()Lỗi GoTo eh'khai báo các biến để giữ các đối tượng được yêu cầuDim wbDestination As WorkbookDim wbSource As WorkbookDim wsDestination As WorksheetDim wb As WorkbookDim sh As WorksheetDim strSheetName thành chuỗiDim strDestName As StringDim iRws As IntegerLàm mờ iCols thành số nguyênDim totRws As IntegerDim strEndRng dưới dạng chuỗiDim rngSource As Range'tắt cập nhật màn hình để tăng tốc mọi thứApplication.ScreenUpdating = Sai'đầu tiên hãy tạo sổ làm việc đích mớiĐặt wbDestination = Workbooks.Add'lấy tên của sổ làm việc mới để bạn loại trừ nó khỏi vòng lặp bên dướistrDestName = wbDestination.Name'bây giờ lặp qua từng sổ làm việc đang mở để lấy dữ liệuĐối với mỗi wb trong ứng dụng.Nếu wb.Name strDestName Và wb.Name "PERSONAL.XLSB" ThìĐặt wbSource = wbĐối với mỗi sh Trong wbSource.Worksheets'lấy số hàng và cột trong trang tínhsh. Kích hoạtActiveSheet.Cells.SpecialCells (xlCellTypeLastCell). Kích hoạtiRws = ActiveCell.RowiCols = ActiveCell.Column'đặt phạm vi của ô cuối cùng trong trang tínhstrEndRng = sh.Cells (iRws, iCols) .Address'đặt phạm vi nguồn để sao chépĐặt rngSource = sh.Range ("A1:" & strEndRng)'tìm hàng cuối cùng trong trang đíchwbDestination.ActivateĐặt wsDestination = ActiveSheetwsDestination.Cells.SpecialCells (xlCellTypeLastCell) .SelecttotRws = ActiveCell.Row'kiểm tra xem có đủ hàng để dán dữ liệu khôngNếu totRws + rngSource.Rows.Count> wsDestination.Rows.Count ThìMsgBox "Không có đủ hàng để đặt dữ liệu trong trang tính Hợp nhất."GoTo ehKết thúc nếu'thêm một hàng để dán trên hàng tiếp theo xuốngNếu totRws 1 Thì totRws = totRws + 1rngSource.Copy Destination: = wsDestination.Range ("A" & totRws)Tiếp theo shKết thúc nếuTuần tiếp theo'bây giờ đóng tất cả các tệp đang mở ngoại trừ tệp bạn muốnĐối với mỗi wb trong ứng dụng.Nếu wb.Name strDestName Và wb.Name "PERSONAL.XLSB" Thìwb. Đóng SaiKết thúc nếuTuần tiếp theo'dọn dẹp các đối tượng để giải phóng bộ nhớĐặt wbDestination = Không có gìĐặt wbSource = Không có gìĐặt wsDestination = Không có gìĐặt rngSource = Không có gìĐặt wb = Không có gì'bật cập nhật màn hình khi hoàn tấtApplication.ScreenUpdating = SaiThoát SubHở:MsgBox Err.DescriptionKết thúc Sub

Kết hợp tất cả các Trang tính từ tất cả các Sổ làm việc đang mở thành một Trang tính duy nhất trong một Sổ làm việc đang hoạt động

Nếu bạn muốn đưa thông tin từ tất cả các Sổ làm việc đang mở khác vào sổ bạn hiện đang làm việc, bạn có thể sử dụng mã này bên dưới.

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081

Sub CombineMultipleSheetsToExisting ()Lỗi GoTo eh'khai báo các biến để giữ các đối tượng được yêu cầuDim wbDestination As WorkbookDim wbSource As WorkbookDim wsDestination As WorksheetDim wb As WorkbookDim sh As WorksheetDim strSheetName thành chuỗiDim strDestName As StringDim iRws As IntegerLàm mờ iCols thành số nguyênDim totRws As IntegerDim rngEnd As StringDim rngSource As Range'đặt đối tượng sổ làm việc đang hoạt động cho sách đíchĐặt wbDestination = ActiveWorkbook'lấy tên của tệp hoạt độngstrDestName = wbDestination.Name'tắt cập nhật màn hình để tăng tốc mọi thứApplication.ScreenUpdating = Sai'đầu tiên hãy tạo trang tính đích mới trong sổ làm việc Hoạt động của bạnApplication.DisplayAlerts = False'tiếp tục lỗi tiếp theo trong trường hợp trang tính không tồn tạiKhi có lỗi Tiếp tục tiếp theoActiveWorkbook.Sheets ("Hợp nhất"). Xóa'đặt lại bẫy lỗi để chuyển đến bẫy lỗi ở cuốiLỗi GoTo ehApplication.DisplayAlerts = True'thêm một trang tính mới vào sổ làm việcVới ActiveWorkbookĐặt wsDestination = .Sheets.Add (Sau: =. Sheets (.Sheets.Count))wsDestination.Name = "Hợp nhất"Kết thúc với'bây giờ lặp qua từng sổ làm việc đang mở để lấy dữ liệuĐối với mỗi wb trong ứng dụng.Nếu wb.Name strDestName Và wb.Name "PERSONAL.XLSB" ThìĐặt wbSource = wbĐối với mỗi sh Trong wbSource.Worksheets'lấy số hàng trong trang tínhsh. Kích hoạtActiveSheet.Cells.SpecialCells (xlCellTypeLastCell). Kích hoạtiRws = ActiveCell.RowiCols = ActiveCell.ColumnrngEnd = sh.Cells (iRws, iCols) .AddressĐặt rngSource = sh.Range ("A1:" & rngEnd)'tìm hàng cuối cùng trong trang đíchwbDestination.ActivateĐặt wsDestination = ActiveSheetwsDestination.Cells.SpecialCells (xlCellTypeLastCell) .SelecttotRws = ActiveCell.Row'kiểm tra xem có đủ hàng để dán dữ liệu khôngNếu totRws + rngSource.Rows.Count> wsDestination.Rows.Count ThìMsgBox "Không có đủ hàng để đặt dữ liệu trong trang tính Hợp nhất."GoTo ehKết thúc nếu'thêm một hàng để dán trên hàng tiếp theo xuống nếu bạn không ở hàng 1Nếu totRws 1 Thì totRws = totRws + 1rngSource.Copy Destination: = wsDestination.Range ("A" & totRws)Tiếp theo shKết thúc nếuTuần tiếp theo'bây giờ đóng tất cả các tệp đang mở ngoại trừ tệp bạn muốnĐối với mỗi wb trong ứng dụng.Nếu wb.Name strDestName Và wb.Name "PERSONAL.XLSB" Thìwb. Đóng SaiKết thúc nếuTuần tiếp theo'dọn dẹp các đối tượng để giải phóng bộ nhớĐặt wbDestination = Không có gìĐặt wbSource = Không có gìĐặt wsDestination = Không có gìĐặt rngSource = Không có gìĐặt wb = Không có gì'bật cập nhật màn hình khi hoàn tấtApplication.ScreenUpdating = SaiThoát SubHở:MsgBox Err.DescriptionKết thúc Sub