Merge multiple workbooks with multiple worksheets into one

[jenmarie]

I am trying to copy multiple worksheets in multiple workbooks into one new workbook with only one worksheet. I would like column A of the destination workbook (the merged data) to have the source workbook's name and column B to list the source workbook's worksheet name. All data has A:AC columns and the number of rows varies by worksheet.
The final piece I'd like to add is if the new consolidated data hits the max of rows permitted in a workbook, I'd like it to start a new workbook to complete the data consolidation process.


Sub MergeAllWorkbooks() Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim NRow As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range


' Create a new workbook and set a variable to the first sheet.
Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)


' Modify this folder path to point to the files you want to use.
FolderPath = "C:\Users\Peter\invoices\"


' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 1


' Call Dir the first time, pointing it to all Excel files in the folder path.
FileName = Dir(FolderPath & "*.xl*")


' Loop until Dir returns an empty string.
Do While FileName <> ""
' Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & FileName)


' Set the cell in column A to be the file name.
SummarySheet.Range("A" & NRow).Value = FileName


' Set the cell in Column B to be the worksheet name.
SummarySheet.Range("B" & NRow).Value = ActiveSheet.Name


' Set the source range.
Set SourceRange = WorkBk.Worksheets(1).Range("A1:AC" & lastRow = ActiveSheet.Cells(Rows.Count, "AC").End(xlUp).Row)
' also try this--not sure which will work: Set SourceRange = WorkBk.Worksheets(1).Range("A1:" & Columns.Count & ":" & Rows.Count)


' Set the destination range to start at column C and
' be the same size as the source range.
Set DestRange = SummarySheet.Range("C" & NRow)
Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
SourceRange.Columns.Count)


' Copy over the values from the source to the destination.
DestRange.Value = SourceRange.Value


' Increase NRow so that we know where to copy data next.
NRow = NRow + DestRange.Rows.Count


' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False


' Use Dir to get the next file name.
FileName = Dir()
Loop


' Call AutoFit on the destination sheet so that all
' data is readable.
SummarySheet.Columns.AutoFit

End Sub

[mancubus]

Sub MergeAllWorkbooks()


Dim WorkBk As Workbook
Dim SummarySheet As Worksheet, SourceSheet As Worksheet
Dim FolderPath As String, FileName As String
Dim SourceRange As Range, DestRange As Range, Headers As Range


With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With

Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
SummarySheet.Range("A1").Value = "File Name"
SummarySheet.Range("B1").Value = "Worksheet Name"

FolderPath = "C:\Users\Peter\invoices\"
FileName = Dir(FolderPath & "*.xl*")

Do While FileName <> ""
Set WorkBk = Workbooks.Open(FolderPath & FileName)
For Each SourceSheet In WorkBk.Worksheets
Set DestRange = SummarySheet.Range("C" & Rows.Count).End(xlUp).Offset(1)
With SourceSheet.UsedRange
Set Headers = .Rows(1)
Set SourceRange = .Offset(1).Resize(.Rows.Count - 1)
DestRange.Resize(.Rows.Count - 1, .Columns.Count).Value = SourceRange.Value
DestRange.Offset(, -1).Resize(.Rows.Count - 1).Value = .Parent.Name
DestRange.Offset(, -2).Resize(.Rows.Count - 1).Value = FileName
End With
Next SourceSheet
WorkBk.Close False
FileName = Dir()
Loop

With SummarySheet
.Range("C1").Resize(, Headers.Columns.Count).Value = Headers.Value
.Columns.AutoFit
.Parent.SaveAs "C:\Users\Peter\summary.xlsx", 51
End With

End Sub

[jenmarie]

Thanks so much. This is a huge help. It runs into problems on this line:

DestRange.Resize(.Rows.Count - 1, .Columns.Count).Value = SourceRange.Value

Any chance you might now why it breaks right there?

[mancubus]

welcome.

what error message did you get?
are there any blank worksheets in workbooks?

[SamT]

I'm bored and I have a completely different coding style than mancubus. Take a look at this one, compare it to mancubus's and see which style you like better. mancubus is a fine coder, so his may be faster than mine. Speed can be important if you are dealing with large enough data dumps to maybe have to use more than one xlsm worksheet, plus, I know there is one superfluous assignment in mine, but I think it reads better that way.

Option Explicit

Sub MergeAllWorkbooks()
Dim FolderPath As String
Dim FileName As String
Dim srcBook As Workbook
Dim destBook As Workbook
Dim destSheet As Worksheet
Dim srcRange As Range
Dim destRange As Range
Dim srcLastRow As Long
Dim destNextRow As Long


FolderPath = "C:\Users\Peter\invoices\"

Set destBook = Workbooks.Add(xlWBATWorksheet)
'destBook.Name = 'Name the new Summary Workbook

FileName = Dir(FolderPath & "*.xl*")
Do While FileName <> ""

Set srcBook = Workbooks.Open(FolderPath & FileName)
srcLastRow = srcBook.Cells(Rows.Count, 1).End(xlUp).Row
Set srcRange = srcBook.Worksheets(1).Range("A1:AC" & srcLastRow)

If srcRange.Rows.Count + destNextRow + 1 > destBook.Rows.Count Then _
destBook.Sheets.Add (xlWBATWorksheet)

Set destSheet = destBook.Sheets(destBook.Sheets.Count)
destNextRow = destSheet.Cells(Rows.Count, 3).End(xlUp).Row + 2
destSheet.Cells(destNextRow, 1).Value = FileName
destSheet.Cells(destNextRow, 2).Value = srcBook.Worksheets(1).Name

Set destRange = destSheet.Range("C" & destNextRow)
srcRange.Copy
destRange.Paste PasteSpecial:=xlPasteValues

srcBook.Close savechanges:=False
FileName = Dir()
Loop

For Each destSheet In destBook.Sheets
destSheet.Columns.AutoFit
Next destSheet

End Sub