If anyone can help please as I cannot find this situation I am looking into on the web. I find examples but they all put into one sheet not honour the originally named sheet name. I have given example of input and output sheets below:-

I have multiple excel worksheets but these worksheets have the same sheet names in each e.g.

a.xlsx. first sheet "fred" with columns:

If anyone can help please as I cannot find this situation I am looking into on the web. I find examples but they all put into one sheet not honour the originally named sheet name. I have given example of input and output sheets below:-

I have multiple excel worksheets but these worksheets have the same sheet names in each e.g.

a.xlsx. first sheet "fred" with columns:

second sheet "bill" with columns:

b.xlsx first sheet also called "fred" with columns:

second sheet also called "bill" with columns

I would want to set each excel worksheet on top of each other into a new worksheet called consolidated.xlsx but I want to retain the name of the source file into the first column of each sheet. I also want to retain the sheet names as they are consistent in each worksheet.

The result I would like: new worksheet completed called consolidated.xlsx first sheet: "fred" contains columns:

second sheet "bill" contains columns:

For the input excel spreadsheets I want to be able to select the folder to loop through the names so don't want the code to have a.xlsx, b.xlsx. Also I want the code to dynamically read the sheet names in each sheet I don't want code to have them named as fred and bill etc. That said I know the sheets are consistently named across each worksheet that will be used and I know that the column names equally are going to be the same. When the rows in each separate worksheet gets concatenated/set into the same sheet name ideally I don't want any blank rows as I would like to be able to filter easily.

Please if anyone can help as I find nothing on forums that preserve the sheets from the original source file they only put everthing into a new sheet called sheet1 which I don't want. I hope this all makes sense?

The code I am currently using is this but it only appends to the first sheet everything but I want it to do a setting the sheets on top of each other in the same format they were originally into a master excel file. I also want to keep the source file as a column so within a sheet I can identify where the append has come from

Sub ConsolidateWorkbooks()
    Dim ws As Worksheet
    Dim wsDest As Worksheet
    Dim wbSource As Workbook
    Dim wbDest As Workbook
    Dim lastRow As Long
    Dim fileDialog As fileDialog
    Dim filePath As Variant
    Dim fileChosen As Integer
   
    ' Create a new workbook for consolidation
    Set wbDest = Workbooks.Add
   
    ' Open file dialog to select workbooks
    Set fileDialog = Application.fileDialog(msoFileDialogFilePicker)
    fileDialog.AllowMultiSelect = True
    fileDialog.Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm", 1
    fileChosen = fileDialog.Show
   
    If fileChosen <> -1 Then Exit Sub ' Exit if no files are chosen
   
    ' Loop through each selected file
    For Each filePath In fileDialog.SelectedItems
        Set wbSource = Workbooks.Open(filePath)
       
        ' Loop through each worksheet in the source workbook
        For Each ws In wbSource.Worksheets
            On Error Resume Next
            Set wsDest = wbDest.Worksheets(ws.Name)
            On Error GoTo 0
           
            ' If the worksheet does not exist in the destination workbook, create it
            If wsDest Is Nothing Then
                Set wsDest = wbDest.Worksheets.Add(After:=wbDest.Sheets(wbDest.Sheets.Count))
                wsDest.Name = ws.Name
            End If
           
            ' Find the last row in the destination worksheet
            If Application.WorksheetFunction.CountA(wsDest.Cells) = 0 Then
                lastRow = 1
            Else
                lastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row + 1
            End If
           
            ' Copy and paste values from source to destination worksheet
            ws.UsedRange.Copy
            wsDest.Cells(lastRow, 1).PasteSpecial Paste:=xlPasteValues
        Next ws
       
        ' Close the source workbook without saving
        wbSource.Close SaveChanges:=False
    Next filePath
   
    ' Clean up
    Application.CutCopyMode = False
    Set wbSource = Nothing
    Set wbDest = Nothing
    Set fileDialog = Nothing
End Sub

Thanks Rob

• excel
• vba
• worksheet

• 5 Hi and welcome to S.O. Please note that this is not a free code writing service. That said, if you could edit your question to show us the code you have so far and an explanation of how it fails to achieve the desired goal, we'll be happy to take a look and suggest a solution. You may also want to consider providing sample data and expected outcome as tables – cybernetic.nomad Commented Mar 19 at 13:00
• Sorry this is my bad I am new to this group. I have added code now which is the closest I have got to solving this one – Rob Oakley Commented Mar 20 at 10:17
• 1 I have voted to reopen your question, but there are two more votes necessary. Not sure if this will happen since your ChatGPT code doesn't come close. Either way, feel free to download my working file from my Google Drive. On the top-right is the download icon. – VBasic2008 Commented Mar 20 at 13:10
• Sheets with the same name share the same columns, but are the columns always in the same order? – Tim Williams Commented Mar 20 at 16:03
• Thanks, yes sheets with same name share the same column names and column names are always in the same order. If you like the excels started out as a empty template with column names fixed and different users have added different data but I want to pull all this together into one big file to examine the differences in user input visually. – Rob Oakley Commented Mar 20 at 16:16

1 Answer 1

Consolidate Workbooks

• It is assumed that all the selected workbooks have the same worksheets with the same columns and the data is contiguous with one row of headers.
• In the first iteration, all sheets of the workbook are copied to a new workbook, the destination workbook, in one go and the formatting and formulas are removed. In the subsequent iterations, each source worksheet's data (no headers) is copied as values below the existing data in the corresponding worksheets of the destination workbook.
• In all destination worksheets, a column is added to hold the names of the workbooks where the data came from.

Sub ConsolidateWorkbooks()
    
    Const SOURCE_COLUMN_TITLE As String = "Source"
    
    ' Open file dialog to select workbooks.
    Dim sFilePaths As FileDialogSelectedItems
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm", 1
        If .Show = 0 Then Exit Sub ' cancelled
        Set sFilePaths = .SelectedItems
    End With
        
    Dim IsFirstWorkbook As Boolean: IsFirstWorkbook = True
    
    Application.ScreenUpdating = False
    
    Dim swb As Workbook, sws As Worksheet, srg As Range
    Dim sFilePath As Variant, swbName As String, RowsCount As Long
    Dim dwb As Workbook, dws As Worksheet, drg As Range, dcell As Range
        
    ' Loop through the selected files.
    For Each sFilePath In sFilePaths
        ' Open the source workbook.
        Set swb = Workbooks.Open(sFilePath)
        swbName = swb.Name
        ' Copy values.
        If IsFirstWorkbook Then ' first workbook
            swb.Worksheets.Copy
            Set dwb = Workbooks(Workbooks.Count)
            For Each dws In dwb.Worksheets
                With dws.Range("A1").CurrentRegion
                    .ClearFormats
                    .Value = .Value
                    RowsCount = .Rows.Count - 1
                    If RowsCount > 0 Then
                        With .Columns(1).Offset(, .Columns.Count)
                            .Cells(1) = SOURCE_COLUMN_TITLE
                            .Resize(RowsCount).Offset(1).Value = swbName
                        End With
                    End If
                End With
            Next dws
            IsFirstWorkbook = False
        Else ' all but first workbook
            For Each sws In swb.Worksheets
                Set dws = Nothing
                On Error Resume Next
                    Set dws = dwb.Worksheets(sws.Name)
                On Error GoTo 0
                If dws Is Nothing Then ' sheet doesn't exist
                    sws.Copy After:=dwb.Sheets(dwb.Sheets.Count)
                    Set dws = dwb.Sheets(dwb.Sheets.Count)
                    With dws.Range("A1").CurrentRegion
                        .ClearFormats
                        .Value = .Value
                        RowsCount = .Rows.Count - 1
                        If RowsCount > 0 Then
                            With .Columns(1).Offset(, .Columns.Count)
                                .Cells(1) = SOURCE_COLUMN_TITLE
                                .Resize(RowsCount).Offset(1).Value = swbName
                            End With
                        End If
                    End With
                Else ' sheet exists
                    With dws.Range("A1").CurrentRegion
                        Set dcell = .Cells(1).Offset(.Rows.Count)
                    End With
                    With sws.Range("A1").CurrentRegion
                        RowsCount = .Rows.Count - 1
                        If RowsCount > 0 Then
                            Set srg = .Resize(RowsCount).Offset(1)
                            Set drg = dcell.Resize(RowsCount, srg.Columns.Count)
                            drg.Value = srg.Value
                            drg.Columns(1).Offset(, drg.Columns.Count) _
                                .Value = swbName
                        End If
                    End With
                End If
            Next sws
        End If
        ' Close the source workbook.
        swb.Close SaveChanges:=False
    Next sFilePath
    
    Application.ScreenUpdating = True
    
    MsgBox "Workbooks consolidated.", vbInformation

End Sub