如何通过Excel VBA匹配目标值后将对应行粘贴到目标工作簿？

原有代码问题点 #

• 源复制区域写法错误：Range("B2:L2" & m)错误拼接了匹配行号m，会选中远超预期的单元格范围，实际需要复制的源区域固定为B2:L2即可
• 目标粘贴位置写死为固定单元格B2:K2，既没有使用匹配返回的行号做动态定位，列范围也和源区域B2:L2不匹配
• 依赖Select、Activate切换工作表的写法稳定性差，一旦激活对象不符合预期就会运行出错

修正后代码 #

Sub VlookUp_Copy_Paste_Other_WB()
    Dim lookupVal As Variant
    Dim matchRow As Variant
    Dim sourceSht As Worksheet
    Dim destSht As Worksheet
    
    ' 绑定工作表对象，无需激活切换工作簿
    Set sourceSht = ThisWorkbook.ActiveSheet
    ' 运行前请确保destination.xlsx已处于打开状态
    Set destSht = Workbooks("destination.xlsx").Sheets(1)
    
    ' 读取查找值
    lookupVal = sourceSht.Range("A2").Value
    ' 在目标表A列执行精确匹配
    matchRow = Application.Match(lookupVal, destSht.Range("A:A"), 0)
    
    ' 未找到匹配值时弹出提示退出
    If IsError(matchRow) Then
        MsgBox "The Value Is Not Found"
        Exit Sub
    End If
    
    ' 复制源固定区域
    sourceSht.Range("B2:L2").Copy
    ' 动态定位到匹配行的B列作为起点粘贴，自动适配源区域尺寸
    destSht.Cells(matchRow, "B").PasteSpecial Paste:=xlPasteAll
    
    ' 清空剪贴板状态
    Application.CutCopyMode = False
End Sub

使用说明 #

• 如果只需要粘贴单元格值不需要保留格式、公式，可以把Paste:=xlPasteAll替换为Paste:=xlPasteValues
• 如果需要批量处理多行数据，只需要加循环遍历源表A列的查找值即可，核心匹配和定位逻辑不需要修改
• 运行代码前必须打开destination.xlsx文件，否则会触发下标越界错误

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