Copy row data from one workbook to another based on row header name

  • I have created a table mapping the row names in my Destination workbook to row names in my source sheet in the sheet named 'Test'.
    I have attached an image showcasing the mapping in columns A and B respectively.


    The destination rows are not successive and there are other rows in between not referring data from the source sheet. The row names in the source sheet are in Column 2 and row names in Destination sheet are in column 1. I need to copy the data from the source sheet rows that have the matching name in the Destination sheet rows as per my mapping from the image attached.

    This is my code:
    Sub Map()

    DestName = "Data Cost Estimate" 'Name of destination sheet

    SourceName = "EST Actuals" 'Name of Source sheet
    MyDir = "Default directory path"

    With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    .Calculation = xlCalculationManual
    End With

    Set Wb = ThisWorkbook
    Set HeadWS = Wb.Worksheets("Test")
    With HeadWS LastHead = .Cells(.Rows.Count, 1).End(xlUp).Row
    Set HeadRange = .Range("A2:A" & LastHead)
    ReDim Heads(LastHead - 2) '-1 for header row in header map and -1 for 0 based arrary

    Heads = HeadRange.Value

    End With

    answer = MsgBox("If you want to select a specific file click Yes, if you want to go to default path and If you are not sure, click Cancel", vbYesCancel + vbQuestion, "User Specified Path")

    If answer = vbYes Then

    MyFile = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")

    Set wkb = Workbooks.Open(MyFile, UpdateLinks:=0)

    With wkb.Worksheets(SourceName)
    .Rows("1:" & HeadRow - 1).EntireRow.Delete

    For j = .Cells(1, .Columns.Count).End(xlToLeft).Column To 1 Step -1

    If IsError(Application.Match(.Cells(1, j), Heads, False)) Then


    HeadRange.Offset(, 1).Copy
    .Range("A1").PasteSpecial Paste:=xlPasteAll, Transpose:=True

    End With

    ElseIf answer = vbCancel Then

    Msgbox "Do nothing"

    Exit Sub

    End If

    With Application
    .CutCopyMode = False
    .Calculation = xlCalculationAutomatic

    End With


    End Sub

    I think it would be easier if I write a function for this process, but I am not sure as to how. The table mapping is in columns A,B respectively. Thank you

Participate now!

Don’t have an account yet? Register yourself now and be a part of our community!