Это серьезная просьба, но у меня был вечер для записи, так что вот код, который, я думаю, сработает. (Знание форматов ваших листов не помогает, но мы можем работать с этим.)
Откройте новую рабочую книгу (это будет ваша основная рабочая книга), перейдите в среду VBA (Alt + F11) и создайте новый модуль («Вставка»> «Модуль»). Вставьте следующий код VBA в окно нового модуля:
Option Explicit
Const NUMBER_OF_SHEETS = 4
Public Sub GiantMerge()
Dim externWorkbookFilepath As Variant
Dim externWorkbook As Workbook
Dim i As Long
Dim mainLastEnd(1 To NUMBER_OF_SHEETS) As Range
Dim mainCurEnd As Range
Application.ScreenUpdating = False
' Initialise
' Correct number of sheets
Application.DisplayAlerts = False
If ThisWorkbook.Sheets.Count < NUMBER_OF_SHEETS Then
ThisWorkbook.Sheets.Add Count:=NUMBER_OF_SHEETS - ThisWorkbook.Sheets.Count
ElseIf ThisWorkbook.Sheets.Count > NUMBER_OF_SHEETS Then
For i = ThisWorkbook.Sheets.Count To NUMBER_OF_SHEETS + 1 Step -1
ThisWorkbook.Sheets(i).Delete
Next i
End If
Application.DisplayAlerts = True
For i = 1 To NUMBER_OF_SHEETS
Set mainLastEnd(i) = GetTrueEnd(ThisWorkbook.Sheets(i))
Next i
' Load the data
For Each externWorkbookFilepath In GetWorkbooks()
Set externWorkbook = Application.Workbooks.Open(externWorkbookFilepath, , True)
For i = 1 To NUMBER_OF_SHEETS
If mainLastEnd(i).Row > 1 Then
' There is data in the sheet
' Copy new data (skip headings)
externWorkbook.Sheets(i).Range("A2:" & GetTrueEnd(externWorkbook.Sheets(i)).Address).Copy ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row + 1, 1)
' Find the end column and row
Set mainCurEnd = GetTrueEnd(ThisWorkbook.Sheets(i))
Else
' No nata in sheet yet (prob very first run)
' Get correct sheet name from first file we check
ThisWorkbook.Sheets(i).Name = externWorkbook.Sheets(i).Name
' Copy new data (with headings)
externWorkbook.Sheets(i).Range("A1:" & GetTrueEnd(externWorkbook.Sheets(i)).Address).Copy ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row, 1)
' Find the end column and row
Set mainCurEnd = GetTrueEnd(ThisWorkbook.Sheets(i)).Offset(, 1)
' Add file name heading
ThisWorkbook.Sheets(i).Cells(1, mainCurEnd.Column).Value = "File Name"
End If
' Add file name into extra column
ThisWorkbook.Sheets(i).Range(ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row + 1, mainCurEnd.Column), mainCurEnd).Value = externWorkbook.Name
Set mainLastEnd(i) = mainCurEnd
Next i
externWorkbook.Close
Next externWorkbookFilepath
Application.ScreenUpdating = True
End Sub
' Returns a collection of file paths, or an empty collection if the user selects cancel
Private Function GetWorkbooks() As Collection
Dim fileNames As Variant
Dim xlFile As Variant
Set GetWorkbooks = New Collection
fileNames = Application.GetOpenFilename(Title:="Please choose the files to merge", _
FileFilter:="Excel Files, *.xls;*.xlsx", _
MultiSelect:=True)
If TypeName(fileNames) = "Variant()" Then
For Each xlFile In fileNames
GetWorkbooks.Add xlFile
Next xlFile
End If
End Function
' Finds the true end of the table (excluding unused columns/rows and rows filled with 0's)
Private Function GetTrueEnd(ws As Worksheet) As Range
Dim lastRow As Long
Dim lastCol As Long
Dim r As Long
Dim c As Long
On Error Resume Next
lastCol = ws.UsedRange.Find("*", , , xlPart, xlByColumns, xlPrevious).Column
lastRow = ws.UsedRange.Find("*", , , xlPart, xlByRows, xlPrevious).Row
On Error GoTo 0
If lastCol <> 0 And lastRow <> 0 Then
' look back through the last rows of the table, looking for a non-zero value
For r = lastRow To 1 Step -1
For c = 1 To lastCol
If ws.Cells(r, c).Text <> "" Then
If ws.Cells(r, c).Text <> 0 Then
Set GetTrueEnd = ws.Cells(r, lastCol)
Exit Function
End If
End If
Next c
Next r
End If
Set GetTrueEnd = ws.Cells(1, 1)
End Function
Сохраните его, и мы готовы начать его использовать.
Запустите макрос GiantMerge . Вы должны выбрать файлы Excel, которые хотите объединить (вы можете выбрать несколько файлов в диалоговом окне обычным способом Windows (Ctrl для выбора нескольких отдельных файлов, Shift для выбора диапазона файлов)). Вам не нужно запускать макрос для всех файлов, которые вы хотите объединить, вы можете сделать это только для нескольких файлов за раз. При первом запуске он настроит вашу основную рабочую книгу на правильное количество листов, назовет листы на основе первой выбранной книги для объединения и добавит заголовки.
Я сделал следующие предположения (не полный список):
- Есть 4 листа (это можно легко изменить, изменив константу в верхней части кода.)
- Листы находятся в одинаковом порядке во всех дополнительных рабочих книгах
- Столбцы на каждом листе находятся в одинаковом порядке во всех книгах (хотя не все листы в книге будут иметь одинаковые столбцы. Например, WorkBook1, Sheet1 имеет столбцы A, B, C, Sheet2 имеет столбцы A, B; WorkBook2, Sheet1 имеет столбцы A, B, C, в Sheet2 есть столбцы A, B. И т. д. Если в рабочей книге есть следующее: Sheet1 имеет столбцы A, C, B, в Sheet2 есть столбцы B, A, то столбцы не будут правильно выровнены)
- В дополнительных книгах нет лишних или отсутствующих столбцов
- На каждом листе в каждой книге есть заголовок (и только в первом ряду на каждом листе)
- Все столбцы должны быть включены (даже если они содержат только 0)
- Все строки в конце таблицы, содержащие только 0, не копируются в мастер
- В дополнительном столбце нужно только имя файла (а не путь к файлу)
- Я не знаю, насколько хорошо это будет работать, если у вас нет данных на некоторых листах (или они просто заполнены нулями)
Надеюсь это поможет.
