VBA - Copy data from more than one worksheet to another based on column headers

[NathanA]

I'd like to copy rows of data from two worksheets ('8105', '9038') to match the column headings in the destination worksheet ('8105 + 9038'). I'm using code because the columns are not in the same order across all three worksheets, and there are many cells.

At the moment, the code I have works for taking data from one worksheet (8105). I'd like to edit the code so that data is taken from the worksheet '8105' and another worksheet titled '9038'. In the worksheet '9038', the headers go from A to AM.

Any guidance would be much appreciated!

Sub CopyHeaders()
    Dim header As Range, headers As Range
    Set headers = Worksheets("8105").Range("A1:AK1")


    For Each header In headers
        If GetHeaderColumn(header.Value) > 0 Then
            Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("8105 + 9038").Cells(2, GetHeaderColumn(header.Value))
        End If
    Next
End Sub


Function GetHeaderColumn(header As String) As Integer
    Dim headers As Range
    Set headers = Worksheets("8105 + 9038").Range("A1:AK1")
    GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function

 

[JackDanIce]

Try:

Sub CopyHeaders_v1()

    Dim rng     As Range
    Dim w8105   As Range
    Dim w9038   As Range
    Dim var     As Variant
    Dim arr()   As Variant
    Dim LR      As Long
    Dim c       As Long
    
    Set w8105 = Sheets("8105").Range("A1:AK1")
    Set w9038 = Sheets("9038").Range("A1:AK1")
    
    Application.ScreenUpdating = False
    
    For Each var In Array(w8105, w9038)
        For Each rng In var
            c = GetHeaderColumn_v1(rng.Value)
            If c > 0 Then
                LR = LastRow(rng) - 1
                arr = rng.Offset(1).Resize(LR).Value
                With Sheets("8105 + 9038")
                    LR = LastRow(.Cells(2, c)) + 1
                    .Cells(LR, c).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
                End With
                Erase arr
            End If
        Next rng
    Next var


    Application.ScreenUpdating = True
    
    Set w8105 = Nothing
    Set w9038 = Nothing

End Sub


Private Function GetHeaderColumn_v1(ByRef header As String) As Long

    Dim headers As Range
    Dim rng     As Range
    
    Set headers = Sheets("8105 + 9038").Range("A1:AK1")
    On Error Resume Next
        headers.Select
        Set rng = headers.Find(header, , xlValues, xlWhole)
    On Error GoTo 0
    
    GetHeaderColumn_v1 = IIf(Not rng Is Nothing, rng.Column, 0)
    
    Set headers = Nothing
    
End Function


Private Function LastRow(ByRef rng As Range) As Long

    With rng.Parent
        LastRow = .Cells(.Rows.Count, rng.Column).End(xlUp).row
    End With

End Function

 

[NathanA]

Thanks, that works so well!