Я думаю, я знаю, что вы после. Если это так, я адаптировал некоторый код, написанный для аналогичной проблемы, в соответствии с вашими требованиями.
Откройте первую из этих папок и создайте в ней рабочую книгу с поддержкой макросов. Имя рабочей книги не имеет значения.
В этой рабочей книге создайте рабочую таблицу с именем «Рабочие книги».
Переключитесь в редактор Visual Basic. Мне нравится распространять свой код на несколько модулей с модулем для каждой цели. Вы можете включить весь приведенный ниже код в один модуль, если вы предпочитаете, если есть только один оператор Option Explicit.
Создайте модуль и назовите его «LibExcel». Следующий код содержит общие подпрограммы из моей библиотеки специфических подпрограмм Excel:
Option Explicit
Public Sub FindLastRowCol(ByRef Wsht As Worksheet, ByRef RowLast As Long, _
ByRef ColLast As Long)
' Sets RowLast to the last row and ColLast to the last column with a value
' in worksheet Wsht. Cells(RowLast, ColLast) need not contain a value.
' That is, the data in Wsht does not have to be rectangular.
' The motivation for coding this routine was the discovery that Find by
' previous row found a cell formatted as Merge and Center but Find by
' previous column did not. I had known that Find would miss merged
' cells but this was new to me.
' Dec16 Coded
' 31Dec16 Corrected handling of UserRange
' 15Feb17 SpecialCells was giving a higher row number than Find for
' no reason I could determine. Added code to check for a
' value on rows and columns above those returned by Find
' 25Jun17 Found column with value above that found by Find. Fixed.
Dim ColCrnt As Long
Dim ColLastFind As Long
Dim ColLastOther As Long
Dim ColLastTemp As Long
Dim ColLeft As Long
Dim ColRight As Long
Dim Rng As Range
Dim RowIncludesMerged As Boolean
Dim RowBot As Long
Dim RowCrnt As Long
Dim RowLastFind As Long
Dim RowLastOther As Long
Dim RowLastTemp As Long
Dim RowTop As Long
With Wsht
Set Rng = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious)
If Rng Is Nothing Then
RowLastFind = 0
ColLastFind = 0
Else
RowLastFind = Rng.Row
ColLastFind = Rng.Column
End If
Set Rng = .Cells.Find("*", .Range("A1"), xlValues, , xlByColumns, xlPrevious)
If Rng Is Nothing Then
Else
If RowLastFind < Rng.Row Then
RowLastFind = Rng.Row
End If
If ColLastFind < Rng.Column Then
ColLastFind = Rng.Column
End If
End If
Set Rng = .Range("A1").SpecialCells(xlCellTypeLastCell)
If Rng Is Nothing Then
RowLastOther = 0
ColLastOther = 0
Else
RowLastOther = Rng.Row
ColLastOther = Rng.Column
End If
Set Rng = .UsedRange
If Rng Is Nothing Then
Else
If RowLastOther < Rng.Row + Rng.Rows.Count - 1 Then
RowLastOther = Rng.Row + Rng.Rows.Count - 1
End If
If ColLastOther < Rng.Column + Rng.Columns.Count - 1 Then
ColLastOther = Rng.Column + Rng.Columns.Count - 1
End If
End If
If RowLastFind < RowLastOther Then
' Higher row found by SpecialCells or UserRange
Do While RowLastOther > RowLastFind
ColLastTemp = .Cells(RowLastOther, .Columns.Count).End(xlToLeft).Column
If ColLastTemp > 1 Or .Cells(RowLastOther, 1).Value <> "" Then
Debug.Assert False
' Is this possible
' Row after RowLastFind has value
RowLastFind = RowLastOther
Exit Do
End If
RowLastOther = RowLastOther - 1
Loop
ElseIf RowLastFind > RowLastOther Then
Debug.Assert False
' Is this possible
End If
RowLast = RowLastFind
If ColLastFind < ColLastOther Then
' Higher column found by SpecialCells or UserRange
Do While ColLastOther > ColLastFind
RowLastTemp = .Cells(.Rows.Count, ColLastOther).End(xlUp).Row
If RowLastTemp > 1 Or .Cells(1, ColLastOther).Value <> "" Then
'Debug.Assert False
' Column after ColLastFind has value
' Possible causes:
' * Find does not recognise merged cells
' ' Find does not examine hidden cells
ColLastFind = ColLastOther
Exit Do
End If
ColLastOther = ColLastOther - 1
Loop
ElseIf ColLastFind > ColLastOther Then
Debug.Assert False
' Is this possible
End If
ColLast = ColLastFind
End With
End Sub
Public Function WshtExists(ByRef Wbk As Workbook, ByVal WshtName As String)
' Returns True if Worksheet WshtName exists within
' * if Wbk Is Nothing the workbook containing the macros
' * else workbook Wbk
' 21Aug16 Coded by Tony Dallimore
' 14Feb17 Coded alternative routine that cycled through the existing worksheets
' matching their names against WshtName to check use of "On Error Resume Next"
' was the faster option. I needed to call the routines 6,000,000 times each to
' get an adequate duration for comparison. This version took 33 seconds while
' the alternative took 75 seconds.
Dim WbkLocal As Workbook
Dim Wsht As Worksheet
If Wbk Is Nothing Then
Set WbkLocal = ThisWorkbook
Else
Set WbkLocal = Wbk
End If
Err.Clear
On Error Resume Next
Set Wsht = WbkLocal.Worksheets(WshtName)
On Error GoTo 0
If Wsht Is Nothing Then
WshtExists = False
Else
WshtExists = True
End If
End Function
Этот код принадлежит модулю «ModPrepare». Обратите внимание, что «Мод» важен. Модуль содержит макрос «Подготовить». Если вы дадите модулю и макросу одно и то же имя, вы получите неясные ошибки.
Option Explicit
Sub Prepare()
' Create list of workbooks (other than this workbook) in current folder
Dim Path As String
Dim RowWbks As Long
Dim WbkName As String
Path = ThisWorkbook.Path & "\"
With Worksheets("Workbooks")
.Cells.EntireRow.Delete
.Cells(1, 1).Value = "New workbook"
.Cells(1, 2).Value = "Existing workbooks"
.Range("A1:B1").Font.Bold = True
RowWbks = 2
WbkName = Dir$(Path & "*.xls*", vbNormal)
Do While WbkName <> ""
If WbkName <> ThisWorkbook.Name Then
.Cells(RowWbks, 2).Value = WbkName
RowWbks = RowWbks + 1
End If
WbkName = Dir$
Loop
.Columns.AutoFit
End With
End Sub
Этот код принадлежит модулю «ModMerge»:
Option Explicit
Const RowSrcDataFirst As Long = 3
Sub Merge()
Dim ColCrnt As Long ' Current column in either current worksheet
Dim ColDestLast As Long ' Last column in current destination worksheet
Dim ColSrcLast As Long ' Last column in current source worksheet
Dim NumShtCrnt As Long ' Number of current worksheet in source and destination workbooks
Dim Path As String ' Folder holding workbooks
Dim RngSrc As Range ' Range to be copied from current source worksheet
Dim RowDestLast As Long ' Last row in current destination worksheet
Dim RowSrcCrnt As Long ' Current row in current source worksheet
Dim RowSrcLast As Long ' Last row in current source worksheet
Dim RowWbksCrnt As Long ' Current row in worksheet "Workbooks"
Dim WbkDest As Workbook ' Reference to destination workbook
Dim WbkSrc As Workbook ' Reference to source workbook
Dim WbkDestName As String ' Name of destination workbook
Dim WbkSrcName As String ' Name of current source workbook
Dim WshtDest As Worksheet ' Reference to current destination worksheet
Dim WshtSrc As Worksheet ' Reference to current source worksheet
Dim WshtWbks As Worksheet ' Reference to worksheet "Workbooks"
Application.ScreenUpdating = False
Set WshtWbks = ThisWorkbook.Worksheets("Workbooks")
Path = ThisWorkbook.Path & "\"
Set WbkDest = Workbooks.Add ' Create new empty workbook
RowWbksCrnt = 2
WbkDestName = WshtWbks.Cells(RowWbksCrnt, 1).Value
Do While True ' Loop until find blank line in worksheet WorkBooks
' Get name of next source workbook
With WshtWbks
WbkSrcName = .Cells(RowWbksCrnt, 2).Value
If WbkSrcName = "" Then Exit Do
RowWbksCrnt = RowWbksCrnt + 1
End With
Debug.Print WbkSrcName;
' Open current source workbook
Set WbkSrc = Workbooks.Open(Path & WbkSrcName, False, False)
' Copy worksheets "Sheet1" to "SheetN" from current
' source workbook to destination workbook
NumShtCrnt = 1
Do While True ' Loop until SheetN does not exist
If Not WshtExists(WbkSrc, "Sheet" & NumShtCrnt) Then
' No more worksheets
Exit Do
End If
Debug.Print " " & NumShtCrnt;
With WbkSrc
Set WshtSrc = .Worksheets("Sheet" & NumShtCrnt)
End With
' Create destination worksheet if it does not exist
With WbkDest
If Not WshtExists(WbkDest, "Sheet" & NumShtCrnt) Then
Set WshtDest = .Worksheets.Add
With WshtDest
.Name = "Sheet" & NumShtCrnt
.Move After:=WbkDest.Worksheets("Sheet" & NumShtCrnt - 1)
End With
Else
Set WshtDest = .Worksheets("Sheet" & NumShtCrnt)
End If
End With
'Debug.Print " " & "Sheet" & NumShtCrnt
' Find dimensions of source worksheet
Call FindLastRowCol(WshtSrc, RowSrcLast, ColSrcLast)
' Find last row of destination worksheet; do not need last column
Call FindLastRowCol(WshtDest, RowDestLast, ColDestLast)
'Debug.Print " Src " & RowSrcLast & " " & ColSrcLast
'Debug.Print " Dest " & RowDestLast & " " & ColDestLast
With WshtSrc
If RowDestLast = 0 Then
' First source worksheet to be copied to this destination sheet
' Include header rows
Set RngSrc = .Range(.Cells(1, 1), .Cells(RowSrcLast, ColSrcLast))
' Copy column widths
For ColCrnt = 1 To ColSrcLast
WshtDest.Columns(ColCrnt).ColumnWidth = WshtSrc.Columns(ColCrnt).ColumnWidth
Next
Else
' Not first worksheet so exclude header rows
Set RngSrc = .Range(.Cells(RowSrcDataFirst, 1), .Cells(RowSrcLast, ColSrcLast))
End If
End With
RngSrc.Copy Destination:=WshtDest.Cells(RowDestLast + 1, 1)
NumShtCrnt = NumShtCrnt + 1
Loop ' for every worksheet in current source workbook
WbkSrc.Close SaveChanges:=False
Debug.Print
Loop ' for every source workbook
WbkDest.Close SaveChanges:=True, Filename:=Path & WbkDestName
Application.ScreenUpdating = False
End Sub
Запустите макрос «Подготовить», чтобы создать список в «Рабочих книгах», например:
В моей папке четыре книги данных;тебе девятнадцатьЭти рабочие книги перечислены в созданной последовательности, которая может не соответствовать той последовательности, которую требуется в новой рабочей книге. Измените этот лист так, чтобы он выглядел примерно так:
Имя в столбце A - это имя, которое будет присвоено новой книге. Я изменил последовательность имен в столбце B на желаемую последовательность вывода. Поэтому сначала будут данные из «Data B.xlsx», затем данные из «Data D.xlsx» и так далее. Если последовательность данных не имеет значения, оставьте один столбец B.
После того, как рабочий лист «Рабочие книги» будет по вашему желанию, запустите макрос «Слияние». Во время выполнения макроса в «Немедленном окне» появляется следующая индикация для приблизительного индикатора прогресса:
Data B.xlsx 1 2 3
Data D.xlsx 1 2 3
Data A.xlsx 1 2 3
Data C.xlsx 1 2 3
У меня только три листа на одну книгу. Макрос обрабатывает столько имен рабочих листов от «Sheets1» до «SheetsN», сколько находит. Так что для вас список номеров листов достигнет 16. У вас будет 19 имен книг. На моем ноутбуке каждая исходная рабочая таблица занимала доли секунды, поэтому весь процесс слияния занимал очень мало времени.
После того, как вы проверили новую книгу данных, переместите рабочую книгу макросов в следующую папку и запустите Подготовка иСлить снова. Повторите для каждой папки.
Комментарии в макросах говорят вам о том, что делает каждый блок кода, но не о том, что делает каждый оператор. При необходимости возвращайтесь с вопросами.