Option Explicit
Sub ConsolidateSheets()
'Author: Jerry Beaucaire
'Date: 6/26/2009
'Updated: 6/23/2010
'Merge all sheets in a workbook into one summary sheet (stacked)
'Data is sorted by a specific column name
Dim cs As Worksheet, WS As Worksheet
Dim LR As Long, NR As Long, sCol As Long
Dim sName As Boolean, SortStr As String
Application.ScreenUpdating = False
'From the headers in data sheets, enter the column title to sort by when finished
SortStr = "Invoice #"
'Add consolidation sheet if needed
If Not Evaluate("ISREF(Consolidate!A1)") Then _
Worksheets.Add(After:=Worksheets(Worksheets.count)).Name = "Consolidate"
'Option to add sheet names to consolidation report
sName = MsgBox("Add sheet names to consolidation report?", vbYesNo + vbQuestion) = vbYes
'Setup
Set cs = ActiveWorkbook.Sheets("Consolidate")
cs.Cells.ClearContents
NR = 1
'Process each data sheet
For Each WS In Worksheets
If WS.Name <> "Consolidate" Then
LR = WS.Range("A" & WS.Rows.count).End(xlUp).Row
'customize this section to copy what you need
If NR = 1 Then 'copy titles and data to start the consolidation
WS.Range("A1", WS.Cells(1, Columns.count).End(xlToLeft)).Copy
If sName Then
cs.Range("B1").PasteSpecial xlPasteAll
Else
cs.Range("A1").PasteSpecial xlPasteAll
End If
NR = 2
End If
WS.Range("A2:BB" & LR).Copy 'copy data
If sName Then 'paste and add sheet names if required
cs.Range("B" & NR).PasteSpecial xlPasteValues
cs.Range("A" & NR, cs.Range("B" & cs.Rows.count).End(xlUp).Offset(0, -1)) = WS.Name
Else
cs.Range("A" & NR).PasteSpecial xlPasteValues
End If
NR = cs.Range("A" & cs.Rows.count).End(xlUp).Row + 1
End If
Next WS
'Sort
LR = cs.Range("A" & cs.Rows.count).End(xlUp).Row
On Error Resume Next
sCol = cs.Cells.Find(SortStr, After:=cs.Range("A1"), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Column
cs.Range("A1:BB" & LR).Sort Key1:=cs.Cells(2, sCol + (IIf(sName, 1, 0))), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'Cleanup
If sName Then cs.[A1] = "Sheet"
cs.Rows(1).Font.Bold = True
cs.Cells.Columns.AutoFit
Application.CutCopyMode = False
Application.ScreenUpdating = True
cs.Activate
Range("A1").Select
Set cs = Nothing
End Sub