Loop to match headers on separate sheets, copy and paste revisited

[damius314]

I am trying to create a spreadsheet with my first tab being the "master sheet" with a varying number of column headers only. There will also be additional sheets in the workbook that have matching column headers with data below it. I would like to be able to search all the other pages, matching columns with the master sheet and pasting the data below the column headers on the master sheet. The code below seemed like it would do the trick, however, after spinning my wheels for hours, I am not able to figure out the error. I attempted to upload a sample file as an xlsx and xlsm and both failed. Any suggestions on why it wouldn't upload?

Thanks for the help.

Here is the code originally posted by SamT

Option Explicit
Sub VBAX_SamT()
'Adjust 2 instances "MasterSheetName" to suit
'For each header in Master Sheet, searches all other sheets for matching header,
'Then copys all data below matching header to bottom of Used Master header column.

Dim rngMasterHeaders As Range
Dim Cel As Range
Dim Sht As Worksheet
Dim CopyHeader As Range
Dim Dest As Range

Set rngMasterHeaders = Sheets("PBT"). _
    Range(Cells(1, "A"), Cells(1, Columns.Count).End(xlToLeft))
    
For Each Cel In rngMasterHeaders
  If Cel.Value <> "" Then
    For Each Sht In Worksheets
      If Sht.Name <> "PBT" Then
        Set CopyHeader = Sht.Range("1:1").Find(Cel.Value)
        If Not CopyHeader Is Nothing Then
          Set Dest = Cel.Parent.Range(Rows.Count, Cel.Column).End(xlUp).Offset(1)
          Range(CopyHeader.Offset(1), Cells(Rows.Count, CopyHeader.Column).End(xlUp)).Copy Dest
          Set CopyHeader = Nothing
        End If
      End If
    Next Sht
  End If
Next Cel       
 End Sub

[jolivanes]

Is this what you mean? Try on a copy of your original first.

Sub Maybe()
Dim sh1 As Worksheet, sht As Worksheet, c As Range, hdrCol As Long
Set sh1 = Worksheets("Master")
Application.ScreenUpdating = False
    For Each sht In ActiveWorkbook.Worksheets
        If sht.Name <> "Master" Then
            With sht
                For Each c In .Range(.Cells(1, 1), .Cells(1, .Cells(1, .Columns.Count).End(xlToLeft).Column))
                    If WorksheetFunction.CountIf(sh1.Rows(1), c) <> 0 Then
                        hdrCol = sh1.Rows(1).Find(c, , , 1).Column
                            .Range(c.Offset(1), c.Offset(1).End(xlDown)).Copy sh1.Cells(Rows.Count, hdrCol).End(xlUp).Offset(1)
                    End If
                Next c
            End With
        End If
    Next sht
Application.ScreenUpdating = True
End Sub

[damius314]

Sorry, it took so long to respond. Thank you, worked like a charm.

[jolivanes]

Thank you for letting us know.
Good luck