Merging Tables

Hello,

I have 40 Sheets in a Workbook that represent different manufacturers.

On each Sheet, there is an identical table (placement, formatting, column titles, etc.). The only difference betwene tables are the products listed in the table (below the column titles/headers).

How would I merge every single table into one very large table?

Hello.

Below code consolidates all worksheets in blank workbook, inserts source sheet names in Column A, saves new workbook in the same folder with source workbook.

copy and paste the code in a standard module of the source workbook.

Sub MergeAllWorksheetsInABlankWorkbook()
     
    Dim SummarySheet As Worksheet, SourceSheet As Worksheet
    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 = "Worksheet Name"
     
    For Each SourceSheet In ThisWorkbook.Worksheets
        Set DestRange = SummarySheet.Range("B" & 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
        End With
    Next SourceSheet
     
    With SummarySheet
        .Range("B1").Resize(, Headers.Columns.Count).Value = Headers.Value
        .Columns.AutoFit
        .Parent.SaveAs ThisWorkbook.Path & "\summary.xlsx", 51
    End With
     
End Sub

It almost looks like it is working until it bugs here:

Set SourceRange = .Offset(1).Resize(.Rows.Count - 1)

any blank worksheets in the workbook?

I re-ran and it worked perfectly. I think it may have been because there were images on the pages or I had a blank sheet like you suggested. I deleted all and it ran wonderfully.

i'm glad it helped.