' consolidates multiple sheets into one
' sheets can have variable headers
' headers will be determined based on all non-excluded sheets at runtime
Public Sub ConsolidateSheets()
Const sOUTPUT_SHEET As String = "Consolidated List"
Const sEXCLUSION_LIST As String = "Exclusion List"
'''''''''''''''''' Declaration section ''''''''''''''''''
' These are the variables we will use for this macro.
' This variable will represent the Excel file we are working with.
Dim wshOurWorkbook As Excel.Workbook
' This will be our output sheet.
Dim wshOutput As Excel.Worksheet
' This will be each of our input sheets.
Dim wshInput As Excel.Worksheet
' This will be the exclusion list worksheet
Dim wshExclusionList As Excel.Worksheet
' This variable will tell whether or not there is an exclusion list.
' If the sheet named sEXCLUSION_LIST does not exist in our workbook, it is set to False.
Dim bExclude As Boolean
' This will be the headers in the output sheet.
Dim rngOutputHeaders As Excel.Range
' This will be the range of headers in each of the input sheets.
Dim rngInputHeaders As Excel.Range
' This is used to cycle through each input header.
Dim rngHeader As Excel.Range
' This is the exclusion list, if one exists.
Dim rngExclusionList As Excel.Range
' This will be used to find each output header.
Dim rng As Excel.Range
' The next row on the output sheet to be populated.
Dim iNextOutputRow As Long
' The number of input rows from each input sheet.
Dim iInputRows As Long
' This is used to determine the total number of input rows needed.
Dim iRow As Long
' This is used to determine whether the current input sheet should be excluded, based on Exclusion List.
Dim iMatch As Long
' to capture unique headers
Dim colHeaders As VBA.Collection
' to determine whether user wants to use existing headers or make new ones
Dim answer As VBA.VbMsgBoxResult
Dim i As Long
'''''''''''''''''' Execution section ''''''''''''''''''
' These are the actual macro steps to be performed.
' For this example, we will assume that this macro resides in your workbook.
' To do this, we activate it.
' Delete or comment out this line if you just want to use whatever workbook is already active.
ThisWorkbook.Activate
' Whether you are using the previous line or not, we will set the workbook we are working with to whatever is activated.
' This workbook is used for the rest of the code.
Set wshOurWorkbook = Application.ActiveWorkbook
' This is our output sheet. The name is defined above as a constant.
On Error Resume Next
Set wshOutput = wshOurWorkbook.Worksheets(sOUTPUT_SHEET)
' An error will occur if the output sheet is not found.
If wshOutput Is Nothing Then
Call MsgBox("Output sheet not found!", vbOKOnly + vbCritical, "Sheet not found")
Exit Sub
End If
Set wshExclusionList = wshOurWorkbook.Worksheets(sEXCLUSION_LIST)
If wshExclusionList Is Nothing Then
Debug.Print "Exclusion list not found."
bExclude = False
Else
bExclude = True
End If
If bExclude Then
With wshExclusionList
Set rngExclusionList = wshExclusionList.Range(.Range("A1"), .Columns(1).Cells(.Cells.Rows.Count).End(xlUp))
End With
bExclude = Not (rngExclusionList Is Nothing)
End If
On Error GoTo 0
answer = vbYes
If Len(wshOutput.Range("A1").Value) > 0 Then
answer = MsgBox("Headers detected on output sheet. Replace?", vbYesNoCancel, "Auto detect headers")
End If
If answer = vbCancel Then
Exit Sub
ElseIf answer = vbYes Then
' instantiate headers collection
Set colHeaders = New VBA.Collection
' clear values
wshOutput.Cells.ClearContents
' find all headers
' use collection to only have unique headers
For Each wshInput In wshOurWorkbook.Worksheets
iMatch = 0
On Error Resume Next
' Check to see whether the current sheet is in the Exclusion List.
If bExclude Then
iMatch = Application.WorksheetFunction.Match(wshInput.Name, rngExclusionList, 0)
End If
' Additionally, check for Exclusion List and Output sheet.
iMatch = (iMatch <> 0) Or (StrComp(wshInput.Name, sOUTPUT_SHEET) = 0) Or (StrComp(wshInput.Name, sEXCLUSION_LIST) = 0)
On Error GoTo 0
' If nothing matched, then we proceed.
If Not iMatch Then
With wshInput
Set rngInputHeaders = .Range(.Range("A1"), .Range("XFD1").End(xlToLeft))
End With
On Error Resume Next
For Each rng In rngInputHeaders.Cells
colHeaders.Add Item:=rng, Key:=CStr(rng.Value)
Next rng
On Error GoTo 0
End If
Next wshInput
For i = 1 To colHeaders.Count
wshOutput.Cells(1, i).Value = colHeaders(i)
Next i
End If
' First, we define the range that contains all the output headers.
' For this example, we assume that the headers begin in A1 and are all contiguous.
' We use the VBA equivalent of End Mode to find the last header from A1.
Set rngOutputHeaders = wshOutput.Range(wshOutput.Range("A1"), wshOutput.Range("A1").End(xlToRight))
' Clear any previous output on the output sheet.
Intersect(rngOutputHeaders.EntireColumn, wshOutput.UsedRange).Offset(1, 0).Clear
' Set the first output row to be one line below the header, i.e. row 2
iNextOutputRow = 2
' We will loop through all the input sheets using the wshInput variable.
For Each wshInput In wshOurWorkbook.Worksheets
' First, check to see whether the sheet should be excluded.
' Output sheet, Exclusion List, and any items on exclusion list are excluded.
' Assume the sheet is an input sheet to begin.
iMatch = 0
On Error Resume Next
' Check to see whether the current sheet is in the Exclusion List.
If bExclude Then
iMatch = Application.WorksheetFunction.Match(wshInput.Name, rngExclusionList, 0)
End If
' Additionally, check for Exclusion List and Output sheet.
iMatch = (iMatch <> 0) Or (StrComp(wshInput.Name, sOUTPUT_SHEET) = 0) Or (StrComp(wshInput.Name, sEXCLUSION_LIST) = 0)
On Error GoTo 0
' If nothing matched, then we proceed.
If Not iMatch Then
Debug.Print "Processing " & wshInput.Name
' Using the same logic as for output headers, we find all our input headers in each input sheet.
Set rngInputHeaders = wshInput.Range(wshInput.Range("A1"), wshInput.Range("A1").End(xlToRight))
' We loop through the input headers, and find the last row of the data.
' We will save the highest row as our last data row, to make sure we capture all the data.
' Again, we use End mode to find the last row. We begin by assuming that there are no input rows.
iInputRows = 0
For Each rngHeader In rngInputHeaders.Cells
' Go to the very last cell in the column, use End mode to find the very last data row
iRow = rngHeader.EntireColumn.Cells(rngHeader.EntireColumn.Cells.Count).End(xlUp).Row - 1
' Keep track of what the last data row is for each column. We will use the highest number.
If iRow > iInputRows Then
iInputRows = iRow
End If
Next rngHeader
If iInputRows > 1 Then
' Now, we loop through all the headers again.
' This time, we look for that same header in the Output sheet.
' If we find it, we copy/paste it.
For Each rngHeader In rngInputHeaders.Cells
' Use the Excel's Find feature.
' We assume at the beginning that there is no header.
' The On Error logic makes sure the correct header is found.
Set rng = Nothing
On Error Resume Next
Set rng = rngOutputHeaders.Find(rngHeader.Value, LookIn:=xlFormulas, lookat:=xlPart, MatchCase:=False)
On Error GoTo 0
' We will only proceed if a header is found, i.e. rng is not "nothing"
If Not rng Is Nothing Then
rngHeader.Offset(1, 0).Resize(rowsize:=iInputRows).Copy Destination:=rng.Offset(rowoffset:=iNextOutputRow - 1)
Else
' If for some reason the header is not found on the output sheet, report the error
Debug.Print rngHeader.Value & " was not found in " & wshOutput.Name & " sheet."
End If
Next rngHeader
' We are done with pasting data from this input sheet.
' Now, advance the next input row by the number of rows we just pasted
iNextOutputRow = iNextOutputRow + iInputRows
Else
Debug.Print "No data rows found on " & wshInput.Name
End If
Else
Debug.Print "Ignoring sheet " & wshInput.Name
End If
Next wshInput
End Sub
