求助：如何用VBA实现跨工作簿按姓名匹配复制数据？

需求回顾 #

已实现CSV文件选择并转换为XLSX格式（对应工作簿wbAdpx，工作表名为ADPX），需补充：从wbAdpx的B2、B3单元格获取固定位置的姓名，在目标工作簿wbNewT（工作表名为ACE）中找到对应姓名的行，将指定数据复制到对应位置。

完整代码 #

Sub MatchData()
    Dim MyFSO As FileSystemObject
    Dim MyFileLoc, ParStr, ParStr1, ParStr2 As String
    Dim MyFd As Office.FileDialog
    Dim MyExtn As Variant
    Dim wbNewT As Workbook, wbAdpx As Workbook
    Dim wsNewT As Worksheet, wsAdpx As Worksheet
    Dim name1 As String, name2 As String
    Dim matchRow1 As Range, matchRow2 As Range
    
    ' 选择下载的CSV文件
    Set MyFSO = New FileSystemObject
    Set MyFd = Application.FileDialog(msoFileDialogFilePicker)

    With MyFd
        .InitialFileName = ThisWorkbook.Path
        .AllowMultiSelect = False
        .Title = "Please select the file."
        .Filters.Clear
        .Filters.Add "All Files", "*.*"   
        If .Show = True Then
            MyFileLoc = .SelectedItems(1)
            MyExtn = MyFSO.GetExtensionName(MyFileLoc)
        Else
            MsgBox "Clicked cancel! No file selected"
            Exit Sub ' 用户取消选择时退出程序
        End If
    End With
    
    ' 将CSV转换为XLSX格式（修正原代码中ActiveWorkbook的误用问题）
    If MyExtn = "csv" Then
        ParStr = Left(MyFileLoc, Len(MyFileLoc) - 4) & ".xlsx"
        ' 打开选中的CSV文件
        Workbooks.Open Filename:=MyFileLoc
        ' 保存为XLSX格式
        ActiveWorkbook.SaveAs Filename:=ParStr, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        ' 关闭原CSV文件
        ActiveWorkbook.Close SaveChanges:=False
        ParStr1 = Mid(ParStr, 33, 9)
        ParStr2 = Mid(ParStr1, 1, 4)
    Else
        MsgBox "Invalid file format!"
        Exit Sub
    End If

    ' 绑定工作簿和工作表对象，避免依赖Active状态
    Set wbNewT = ThisWorkbook
    Set wsNewT = wbNewT.Sheets("ACE")
    Set wbAdpx = Workbooks.Open(ParStr)
    Set wsAdpx = wbAdpx.Sheets("ADPX")
    
    ' 获取wbAdpx中的两个目标姓名
    name1 = wsAdpx.Range("B2").Value
    name2 = wsAdpx.Range("B3").Value
    
    ' 查找第一个姓名并复制对应数据（示例复制C列数据，可按需修改）
    Set matchRow1 = wsNewT.Range("A:A").Find(What:=name1, LookIn:=xlValues, LookAt:=xlWhole)
    If Not matchRow1 Is Nothing Then
        wsNewT.Cells(matchRow1.Row, "C").Value = wsAdpx.Range("C2").Value
        ' 可添加更多复制逻辑，比如：
        ' wsNewT.Cells(matchRow1.Row, "D").Value = wsAdpx.Range("D2").Value
    Else
        MsgBox "未找到姓名：" & name1
    End If
    
    ' 查找第二个姓名并复制对应数据
    Set matchRow2 = wsNewT.Range("A:A").Find(What:=name2, LookIn:=xlValues, LookAt:=xlWhole)
    If Not matchRow2 Is Nothing Then
        wsNewT.Cells(matchRow2.Row, "C").Value = wsAdpx.Range("C3").Value
        ' 可添加更多复制逻辑，比如：
        ' wsNewT.Cells(matchRow2.Row, "D").Value = wsAdpx.Range("D3").Value
    Else
        MsgBox "未找到姓名：" & name2
    End If
    
    ' 收尾：关闭转换后的工作簿，保存目标工作簿
    wbAdpx.Close SaveChanges:=False
    wbNewT.Save
    
    MsgBox "数据匹配复制完成！"
End Sub

关键细节说明 #

1. 修复原代码Bug：修正了原代码中误用ActiveWorkbook导致覆盖当前工作簿的问题，改为先打开CSV文件再保存为XLSX
2. 精准姓名匹配：用Range.Find方法配合LookAt:=xlWhole确保完全匹配姓名，避免部分匹配的错误
3. 灵活数据复制：示例中复制C列数据，可根据实际需求修改单元格引用（替换C2/C3和目标列标识即可）
4. 异常处理：添加了退出逻辑和未找到姓名的提示，避免无意义的代码执行

内容的提问来源于stack exchange，提问作者Ven