根据第一列中的行标题名称将行数据从一个工作簿复制到另一个工作簿

Question

我创建了一个表，将我的目标工作簿中的行名映射到名为'Test'的工作表中的源名称中。它如下：

MAP：

目标行不是连续的，并且在其间没有引用源表中的数据之间存在其他行。源表中的行名称位于第2列，“目标”表中的行名称位于第1列中。我需要根据附加图像中的映射从“目标”表行中具有匹配名称的源表行中复制数据

这是我的代码：

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)

    wkb.Worksheets(SourceName).Copy

With wkb.Worksheets(SourceName)
     '.Cells.UnMerge 'uncomment this line if you want merged cells to be unmerged
    'HeadRow = .Columns(1).Find("Brand Title").Row
    '.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 .Columns(j).Delete
    Next
    HeadRange.Offset(, 1).Copy
    .Range("A1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
End With
ThisWorkbook.Save

ElseIf answer = vbCancel then

Msgbox "Do nothing"
Exit Sub

End If

With Application
    .CutCopyMode = False
    .Calculation = xlCalculationAutomatic
End With


End Sub

我认为如果我为这个过程编写一个函数会更容易，但我不确定如何。 表映射分别在列A，B中。 谢谢