VBA Code to Consolidate Several Specific Sheets from Seperate Workbooks

Question

VBA Code to Consolidate Several Specific Sheets from Seperate Workbooks

Alejandro Ruiz Solano 20

I have to copy data from specific sheets that are from separate workbooks. The workbooks have the same first sheet, and the following sheets have the same title but a consecutive # gets added at the end. The first sheet's name is 'Results', the second sheet is 'Info 1', the third sheet 'Info 2', etc. I need to copy 'Info 1' and 'Info 2' and consolidate the data into one new workbook / sheet, 'Info'.
My main issue is that the only constant the sheets contain is the title 'Info' and I can never know how many 'Info' sheets there will be, there could be 'Info 25'. The secondary issue is that there are 2-3 workbooks with these 'Info' sheets.
I need to combine the 'Info' sheets from each workbook into 1 sheet in a new workbook.

All the workbooks are located in the same folder.

I'm wondering if someone could please help me create a VBA code for this? I'm new to VBA and would really appreciate your help!

Please let me know if you require any clarification.

Thank you,

0 comments

Answer accepted by question author

0 additional answers

Your answer

Answer 1

Marcin Policht 95,185 MVP Volunteer Moderator

Try the following:

Option Explicit

Sub ConsolidateInfoSheets()

    Dim FolderPath As String
    Dim FileName As String
    
    Dim SourceWB As Workbook
    Dim SourceWS As Worksheet
    
    Dim DestWB As Workbook
    Dim DestWS As Worksheet
    
    Dim LastRow As Long
    Dim LastCol As Long
    Dim DestRow As Long
    
    Dim FirstPaste As Boolean
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    'Folder containing the workbooks
    FolderPath = "C:\YourFolderPath\"
    
    'Create new workbook for consolidated data
    Set DestWB = Workbooks.Add
    Set DestWS = DestWB.Sheets(1)
    DestWS.Name = "Info"
    
    DestRow = 1
    FirstPaste = True
    
    'Loop through all Excel files in folder
    FileName = Dir(FolderPath & "*.xlsx")
    
    Do While FileName <> ""
    
        'Skip the destination workbook if saved in same folder
        If FileName <> DestWB.Name Then
        
            Set SourceWB = Workbooks.Open(FolderPath & FileName)
            
            'Loop through all sheets
            For Each SourceWS In SourceWB.Worksheets
            
                'Check if sheet name starts with "Info"
                If Left(SourceWS.Name, 4) = "Info" Then
                
                    With SourceWS
                    
                        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
                        
                        'Copy headers only once
                        If FirstPaste Then
                        
                            .Range(.Cells(1, 1), .Cells(LastRow, LastCol)).Copy _
                                DestWS.Cells(DestRow, 1)
                                
                            DestRow = DestWS.Cells(DestWS.Rows.Count, 1).End(xlUp).Row + 1
                            FirstPaste = False
                            
                        Else
                        
                            'Skip header row after first sheet
                            If LastRow > 1 Then
                            
                                .Range(.Cells(2, 1), .Cells(LastRow, LastCol)).Copy _
                                    DestWS.Cells(DestRow, 1)
                                    
                                DestRow = DestWS.Cells(DestWS.Rows.Count, 1).End(xlUp).Row + 1
                                
                            End If
                            
                        End If
                        
                    End With
                    
                End If
                
            Next SourceWS
            
            SourceWB.Close SaveChanges:=False
            
        End If
        
        FileName = Dir
        
    Loop
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    MsgBox "Info sheets consolidated successfully!"

End Sub

If the above response helps answer your question, remember to "Accept Answer" so that others in the community facing similar issues can easily find the solution. Your contribution is highly appreciated.

hth

Marcin

Alejandro Ruiz Solano 20 Reputation points

2026-06-23T23:12:44.3866667+00:00

Hello Marcin, thank you for assisting me. I've tried running the code and it appears to "successfully" consolidate the data but the final Summary sheet doesn't show any data from the 'Info' sheets.
Alejandro Ruiz Solano 20 Reputation points

2026-06-23T23:16:43.4933333+00:00

I created these simple Data Workbooks with 'Info' sheets and random data within them to test the code but it doesn't seem to to copy / paste the data to the final Summary sheet.

Marcin Policht 95,185 MVP Volunteer Moderator

Try this version instead...

Option Explicit

Sub ConsolidateInfoSheets()

    Dim FolderPath As String
    Dim FileName As String
    
    Dim SourceWB As Workbook
    Dim SourceWS As Worksheet
    
    Dim DestWB As Workbook
    Dim DestWS As Worksheet
    
    Dim LastRow As Long
    Dim LastCol As Long
    Dim DestRow As Long
    
    Dim FirstSheet As Boolean
    
    Application.ScreenUpdating = False
    
    'CHANGE THIS PATH
    FolderPath = "C:\YourFolderPath\"
    
    'Create summary workbook
    Set DestWB = Workbooks.Add
    Set DestWS = DestWB.Sheets(1)
    
    DestWS.Name = "Summary"
    
    DestRow = 1
    FirstSheet = True
    
    'Get all Excel files
    FileName = Dir(FolderPath & "*.xls*")
    
    Do While FileName <> ""
    
        Set SourceWB = Workbooks.Open(FolderPath & FileName)
        
        For Each SourceWS In SourceWB.Worksheets
        
            'Find sheets named Info 1, Info 2, etc.
            If SourceWS.Name Like "Info*" Then
            
                With SourceWS
                
                    'Find actual last used row/column
                    LastRow = .Cells.Find("*", SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious).Row
                        
                    LastCol = .Cells.Find("*", SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious).Column
                    
                    If FirstSheet Then
                    
                        'Copy entire first Info sheet
                        .Range(.Cells(1, 1), .Cells(LastRow, LastCol)).Copy _
                            Destination:=DestWS.Cells(DestRow, 1)
                            
                        FirstSheet = False
                        
                    Else
                    
                        'Copy without headers
                        If LastRow > 1 Then
                        
                            .Range(.Cells(2, 1), .Cells(LastRow, LastCol)).Copy _
                                Destination:=DestWS.Cells(DestRow, 1)
                                
                        End If
                        
                    End If
                    
                    'Next available row
                    DestRow = DestWS.Cells(DestWS.Rows.Count, 1).End(xlUp).Row + 1
                    
                End With
                
            End If
            
        Next SourceWS
        
        SourceWB.Close SaveChanges:=False
        
        FileName = Dir
        
    Loop
    
    Application.ScreenUpdating = True
    
    MsgBox "Summary sheet created successfully!"

End Sub

If the above response helps answer your question, remember to "Accept Answer" so that others in the community facing similar issues can easily find the solution. Your contribution is highly appreciated.

hth

Marcin

Alejandro Ruiz Solano 20 Reputation points

2026-06-24T16:16:19.8966667+00:00

Yes, all the info is being consolidated successfully, thank you so much, Marcin!