consolidate multiple worksheets into one worksheet

Question

I want to consolidate multiple worksheets into one worksheet in the same excel, but i don't want some data after a specific word "Total" in all the worksheets. What should i do to delete the data after the word "Total" and then consolidate all the sheets. Below code is written to add multiple worksheets.

Sub Consolidate()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim erow As Long, lrowsh As Long, startrow As Long
Dim CopyRng As Range
startrow = 3
With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Deleting "Consolidate" sheet
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Consolidate").Delete
On Error GoTo 0
Application.DisplayAlerts = True



'Adding worksheet with the name "Consolidate"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Consolidate"
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
'Find the next blank or empty row on the DestSh
erow = DestSh.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
'Find the last row with data in the Sheet
lrowsh = sh.Range("A" & Rows.Count).End(xlUp).Row



Set CopyRng = sh.Range(sh.Rows(startrow), sh.Rows(lrowsh))

'copies Values / formats
CopyRng.Copy
With DestSh.Cells(erow, 1)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

End If
Next
End Sub

The line lrowsh = sh.Range("A" & Rows.Count).End(xlUp).Row in the above code specifies the last used row in each sheet. In its place you would like to have the last row before the word "Total". The word "Total" would be easier to find if you know which column it will be in. Anyway, lrowsh would probably be the row before the row of the cell where "Total" is found, if it is found. — Variatus
Do the sheets have an identical number of used columns? If they do, do you want to copy the headers (titles) in the first two rows of Destination Sheet? — VBasic2008

VBasic2008 VBasic2008 · Accepted Answer · 2019-03-05T16:40:45

Interesting Workbook Consolidation

Change the constants (Const) to fit your needs.

The Code

Sub Consolidate()

    ' Target
    Const cTarget As String = "Consolidate"   ' Target Worksheet Name
    ' Source
    Const cFR As Long = 3             ' First Row Number
    Const cLRC As Variant = 1         ' Last-Row Column Letter/Column Number
    Const cCrit As String = "Total"   ' Criteria

    Dim wb As Workbook    ' Target Workbook
    Dim wsT As Worksheet  ' Target Worksheet
    Dim ws As Worksheet   ' Current Source Worksheet
    Dim eRow As Long      ' Target First Empty Row
    Dim lRow As Long      ' Source Last Used Row
    Dim lCol As Long      ' Source Last Used Column
    Dim rngCell As Range  ' Cell Ranges
    Dim rng As Range      ' Ranges

    ' Speed up.
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    ' Create a reference to Target Workbook. If the code will NOT be in the
    ' workbook to be processed, then use its name (preferable) or
    ' ActiveWorkbook instead of ThisWorkbook.
    Set wb = ThisWorkbook

    ' Note: Instead of the following with block you could use code to clear
    '       or clear the contents of the Target Worksheet.
    With wb
        'Delete Target Worksheet.
        Application.DisplayAlerts = False
        On Error Resume Next
        .Worksheets("Consolidate").Delete
        On Error GoTo 0
        Application.DisplayAlerts = True
        'Add Target Worksheet.
        Set wsT = .Worksheets.Add(Before:=.Sheets(1)) ' First Tab
        wsT.Name = "Consolidate"
    End With

    ' Handle errors.
    On Error GoTo ErrorHandler

    ' Loop through all worksheets.
    For Each ws In wb.Worksheets
        If ws.Name <> wsT.Name Then
            With ws.Cells(cFR, cLRC).Resize(ws.Rows.Count - cFR + 1, _
                    ws.Columns.Count - cLRC + 1)
                ' Note: Choose only one of the following two lines.
                'Find the first occurrence of Criteria in Current Worksheet.
                Set rngCell = .Find(cCrit, .Cells(.Rows.Count, .Columns _
                        .Count), xlValues, xlWhole, xlByRows, xlNext)
'                   'Find the last occurrence of Criteria in Current Worksheet.
'                    Set rng = .Find(cCrit, , xlValues, xlWhole, xlByRows, _
'                            xlPrevious)
                ' Clear the range below the row where Criteria was found.
                ws.Rows(rngCell.Row + 1 & ":" & ws.Rows.Count).Clear
                ' Create a reference to Row Range (of Copy Range).
                Set rng = .Cells(1).Resize(rngCell.Row - cFR + 1, _
                        .Columns.Count - cLRC + 1)
            End With
            ' Create a reference to last cell in last column of Row
            ' Range (of Copy Range).
            Set rngCell = rng.Find("*", , xlFormulas, , _
                    xlByColumns, xlPrevious)
            ' Create a reference to Copy Range.
            Set rng = rng.Cells(1).Resize(rng.Rows.Count, _
                    rngCell.Column - cLRC + 1)

            'Find the next blank or empty row in Target Worksheet.
            eRow = wsT.Cells(wsT.Rows.Count, cLRC).End(xlUp) _
                    .Offset(1, 0).Row
            ' Copy Copy Range.
            rng.Copy
            ' In (First Empty Row of) Target Worksheet
            With wsT.Cells(eRow, 1)
                ' First paste the formats to avoid trouble mostly when pasting
                ' dates or time. Excel might firstly format it differently, and
                ' when pasting the formats might not revert to desired formats.
                .PasteSpecial xlPasteFormats
                .PasteSpecial xlPasteValues
                Application.CutCopyMode = False
            End With

        End If

    Next

    ' Go to the top of Target Worksheet.
    ActiveSheet.Range("A1").Select

    ' Inform user of success (Since the code is fast, you might not know if it
    ' had run at all).
    MsgBox "The operation finished successfully.", vbInformation, "Success"

ProcedureExit:

    ' Speed down.
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

Exit Sub

ErrorHandler:

    MsgBox "An unexpected error occurred. Error '" & Err.Number & "': " _
            & Err.Description, vbCritical, "Error"
    GoTo ProcedureExit

End Sub

consolidate multiple worksheets into one worksheet

1 Answers

Interesting Workbook Consolidation

The Code