Esse é um pedido poderoso que você tem, mas eu tive uma noite para gravar, então aqui está um código que acho que funcionará. (Não saber os formatos das suas planilhas não ajuda, mas podemos trabalhar com isso.)
Abra uma nova pasta de trabalho (essa será sua pasta de trabalho principal), vá para o ambiente VBA (Alt + F11) e crie um novo módulo (Módulo Insert >). Cole o seguinte código do VBA na nova janela do módulo:
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
Salve e estamos prontos para começar a usá-lo.
Execute a macro GiantMerge . Você tem que selecionar os arquivos do Excel que você deseja mesclar (você pode selecionar vários arquivos com a caixa de diálogo, no modo usual do Windows (Ctrl para selecionar vários arquivos individuais, Shift para selecionar um intervalo de arquivos)). Você não precisa executar a macro em todos os arquivos que deseja mesclar, você pode fazer isso em apenas alguns de cada vez. Na primeira vez que você executá-lo, ele configurará sua planilha mestre para ter o número correto de planilhas, nomeará as planilhas com base na primeira pasta de trabalho selecionada para mesclar e incluirá os cabeçalhos.
Eu fiz as seguintes suposições (não uma lista completa):
- Existem 4 folhas (Isso pode ser facilmente alterado alterando a constante na parte superior do código).
- As folhas estão na mesma ordem em todas as pastas de trabalho extras
- As colunas em cada folha estão na mesma ordem em todas as pastas de trabalho (embora nem todas as folhas em um caderno de trabalho tenham as mesmas colunas. Por exemplo, WorkBook1, Sheet1 tem colunas A, B, C, Sheet2 possui colunas A, B; WorkBook2, Sheet1 tem colunas A, B, C, Sheet2 tem colunas A, B. Etc. Se uma pasta de trabalho tiver o seguinte: Sheet1 tem colunas A, C, B, Sheet2 tem colunas B, A, em seguida, as colunas não serão alinhadas corretamente )
- Não há colunas extras ou ausentes nas pastas de trabalho extras
- Existe uma linha de título em cada folha em cada pasta de trabalho (e está na primeira linha em cada folha apenas)
- Todas as colunas devem ser incluídas (mesmo que contenham apenas 0's)
- Todas as linhas no final de uma tabela contendo apenas 0s não são copiadas para o mestre
- É apenas o nome do arquivo (e não o caminho do arquivo) que você precisa na coluna extra
- Eu não sei quão bem isso funcionará se você não tiver dados em algumas das planilhas (ou eles estão apenas preenchidos com zeros)
Espero que isso ajude.