Combine multiple sheets one below the other (sheets not in table format)

[asivaraman]

Hello SMEs
I have an excel file with multiple sheets.
First 2 columns are the same type of data in all the sheets.

I tried powerquery to append, but somehow it doesnt come out right.
Note: The sheets are not table formatted, that is why its not working out with Powerquery.

Can anyone provide a VBA script to combine columns from all the sheets into one? Any other solution is fine as well.

Reference image:

You can see there are multiple tabs/sheets below. I need a script that can copy col A, B, C ... from all the sheets, one below the other into a single sheet/workbook.

 

[Logit]

This method copies all columns A:Z to a main sheet named IMPORT :

Option Explicit


Public Sub CombineDataFromAllSheets()

    Dim wksSrc As Worksheet, wksDst As Worksheet
    Dim rngSrc As Range, rngDst As Range
    Dim lngLastCol As Long, lngSrcLastRow As Long, lngDstLastRow As Long
    
    'Notes: "Src" is short for "Source", "Dst" is short for "Destination"
    
    'Set references up-front
    Set wksDst = ThisWorkbook.Worksheets("Import")
    lngDstLastRow = LastOccupiedRowNum(wksDst) '<~ defined below
    lngLastCol = LastOccupiedColNum(wksDst) '<~ defined below
    
    'Set the initial destination range
    Set rngDst = wksDst.Cells(lngDstLastRow, 1)
    
    'Loop through all sheets
    For Each wksSrc In ThisWorkbook.Worksheets
    
        'Make sure we skip the "Import" destination sheet!
        If wksSrc.Name <> "Import" Then
            
            'Identify the last occupied row on this sheet
            lngSrcLastRow = LastOccupiedRowNum(wksSrc)
            
            'Store the source data then copy it to the destination range
            With wksSrc
                Set rngSrc = .Range("A1:Z100")
                rngSrc.Copy Destination:=rngDst
            End With
            
            'Redefine the destination range now that new data has been added
            lngDstLastRow = LastOccupiedRowNum(wksDst)
            Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)
            
        End If
    
    Next wksSrc

End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT       : Sheet, the worksheet we'll search to find the last row
'OUTPUT      : Long, the last occupied row
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
    Dim lng As Long
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        With Sheet
            lng = .Cells.Find(What:="*", _
                              After:=.Range("A1"), _
                              Lookat:=xlPart, _
                              LookIn:=xlFormulas, _
                              SearchOrder:=xlByRows, _
                              SearchDirection:=xlPrevious, _
                              MatchCase:=False).Row
        End With
    Else
        lng = 1
    End If
    LastOccupiedRowNum = lng + 1   '<-- the + 1 places a blank row between tables
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT       : Sheet, the worksheet we'll search to find the last column
'OUTPUT      : Long, the last occupied column
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
    Dim lng As Long
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        With Sheet
            lng = .Cells.Find(What:="*", _
                              After:=.Range("A1"), _
                              Lookat:=xlPart, _
                              LookIn:=xlFormulas, _
                              SearchOrder:=xlByColumns, _
                              SearchDirection:=xlPrevious, _
                              MatchCase:=False).Column
        End With
    Else
        lng = 1
    End If
    LastOccupiedColNum = lng
End Function

 

[Logit]

Here are two other methods :

Sub master_sheet()
    Dim wsM As Worksheet
    Set wsM = Sheets("Master")
    'assumes Master sheet is the first sheet
    For x = 2 To Worksheets.Count
        Sheets(x).UsedRange.Copy Destination:=wsM.Cells(1, wsM.UsedRange.Columns(wsM.UsedRange.Columns.Count).Column + 1)
    Next x
    wsM.Columns("A").Delete
End Sub

ANOTHER WAY:

Sub master_sheet()

    Dim wsM As Worksheet
    Set wsM = Sheets("Master")
    
    'assumes Master sheet is the first sheet
    For x = 2 To Worksheets.Count
        Sheets(x).UsedRange.Copy Destination:=wsM.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
        
    Next x
    wsM.Columns("A").Delete
End Sub

 

[Logit]

And one last method :

Option Explicit

Sub Maybe()
    Dim sh As Worksheet
    If Not [ISREF(Combined!A1)] Then
        Sheets.Add(, Sheets(Sheets.Count)).Name = "Combined"
    Else
        Sheets("Combined").UsedRange.EntireColumn.Delete
    End If
    'Sheets("Sheet2").Rows(1).Copy Sheets("Combined").Cells(1, 1)  ' Not needed
    For Each sh In ActiveWorkbook.Sheets
        If sh.Name <> "Combined" Then sh.UsedRange.Offset(1).Copy Sheets("Combined").Cells(Rows.Count, 1).End(xlUp).Offset(1)
    Next sh
End Sub

 

[asivaraman]

Thank you Logit. Amazing.
It works perfect.

 

[Logit]

Great. Glad to help.

 

[asivaraman]

Hello Logit,
I have one minor problem with the "last method" you posted.

Option Explicit

Sub Maybe()
Dim sh As Worksheet
If Not [ISREF(Combined!A1)] Then
Sheets.Add(, Sheets(Sheets.Count)).Name = "Combined"
Else
Sheets("Combined").UsedRange.EntireColumn.Delete
End If
'Sheets("Sheet2").Rows(1).Copy Sheets("Combined").Cells(1, 1) ' Not needed
For Each sh In ActiveWorkbook.Sheets
If sh.Name <> "Combined" Then sh.UsedRange.Offset(1).Copy Sheets("Combined").Cells(Rows.Count, 1).End(xlUp).Offset(1)
Next sh
End Sub

The result removes the first row from all the sheets.
I am wondering which syntax to change so it copies all the rows one below the other.

 

[Logit]

Sub Maybe()
    Dim sh As Worksheet
    If Not [ISREF(Combined!A1)] Then
        Sheets.Add(, Sheets(Sheets.Count)).Name = "Combined"
    Else
        Sheets("Combined").UsedRange.EntireColumn.Delete
    End If
    'Sheets("Sheet2").Rows(1).Copy Sheets("Combined").Cells(1, 1)  ' Not needed
    For Each sh In ActiveWorkbook.Sheets
        If sh.Name <> "Combined" Then sh.UsedRange.Copy Sheets("Combined").Cells(Rows.Count, 1).End(xlUp).Offset(1)
    Next sh
End Sub

 

[asivaraman]

Got it, its the UsedRange.Offset(1) that did it.
It works now.

Thank you again.
Arun

 

[Logit]

You are welcome.