Copy Data from One workbook to another using column header

Question

Does any one have a piece of code to copy from one excel WB to another based on column headers?

Update: Sorry to all, I am new to this site and I hope you can forgive

Answer 1

Function GetColumn(GCSheet As Worksheet, ColumnName As String) As Integer
    Dim intCol As Integer

    On Error Resume Next
    intCol = Application.WorksheetFunction.Match(ColumnName, GCSheet.Rows(1), 0)
    If Err.Number <> 0 Then
        GetColumn = 0
    Else
        GetColumn = intCol
    End If
End Function

Use that for your source worksheet and your destination. You could also use "Find". This assumes your columns are in row 1.

Then it's just a case of

wsDestination.cells(intDestRow, GetColumn(wsDestination, "ColumnName")).value = _
    wsSource.cells(intSourceRow,GetColumn(wsSource, "ColumnName")).value

Answer 2

The following code should be able to be altered to suit your needs...

Sub CopyByHeader()

    Dim SourceWS As Worksheet
    Set SourceWS = Workbooks("Source.xlsx").Worksheets(1)
    Dim SourceHeaderRow As Integer: SourceHeaderRow = 1

    Dim TargetWS As Worksheet
    Set TargetWS = Workbooks("Business Loader V7.1.xlsx").Worksheets(2)
    Dim TargetHeader As Range
    Set TargetHeader = TargetWS.Range("A1:AX1")

    Dim RealLastRow As Long
    Dim SourceCol As Integer

    SourceWS.Activate            
    For Each Cell In TargetHeader
        SourceCol = SourceWS.Rows(SourceHeaderRow).Find _
            (Cell.Value, LookIn:=xlValues, LookAt:=xlWhole).Column
        If SourceCol <> 0 Then
            RealLastRow = SourceWS.Columns(SourceCol).Find("*", LookIn:=xlValues, _
                 SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            SourceWS.Range(Cells(SourceHeaderRow + 1, SourceCol), Cells(RealLastRow, _
                  SourceCol)).Copy
            TargetWS.Cells(2, Cell.Column).PasteSpecial xlPasteValues
        End If
    Next

End Sub

UPDATE: Some errors with headers not in source sheet or empty columns. It's also worth noting that with this code - you have to have 'Source.xlsx' open to read from it.

UPDATED CODE:

Sub CopyByHeader()

    Dim CurrentWS As Worksheet
    Set CurrentWS = ActiveSheet

    Dim SourceWS As Worksheet
    Set SourceWS = Workbooks("Source.xlsx").Worksheets(1)
    Dim SourceHeaderRow As Integer: SourceHeaderRow = 1
    Dim SourceCell As Range

    Dim TargetWS As Worksheet
    Set TargetWS = Workbooks("Business Loader V7.1.xlsx").Worksheets(2)
    Dim TargetHeader As Range
    Set TargetHeader = TargetWS.Range("A1:AX1")

    Dim RealLastRow As Long
    Dim SourceCol As Integer

    SourceWS.Activate
    For Each Cell In TargetHeader
        If Cell.Value <> "" Then
            Set SourceCell = Rows(SourceHeaderRow).Find _
                (Cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
            If Not SourceCell Is Nothing Then
                SourceCol = SourceCell.Column
                RealLastRow = Columns(SourceCol).Find("*", LookIn:=xlValues, _
                SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                If RealLastRow > SourceHeaderRow Then
                    Range(Cells(SourceHeaderRow + 1, SourceCol), Cells(RealLastRow, _
                        SourceCol)).Copy
                    TargetWS.Cells(2, Cell.Column).PasteSpecial xlPasteValues
                End If
            End If
        End If
    Next

    CurrentWS.Activate

End Sub