Excel VBA改造：跨工作簿匹配列值后粘贴指定Range区域数据

需求背景 #

现有绑定至工作簿按钮的VBA导入宏，原运行逻辑如下：

• 弹出文件选择框，用户选取目标Excel文件后自动打开
• 复制源文件内QUOTATION工作表的U2:AH2单元格区域
• 跳过空值，以纯值粘贴形式写入当前工作簿QUOTATION工作表的E30单元格
• 不保存更改直接关闭打开的源文件

需调整宏逻辑为：将源文件待复制的U2:AH2区域，粘贴到当前活动工作表中，D列值与源文件T2单元格内容完全匹配的对应行位置，粘贴起始列保持E列不变，仍保留跳过空值、纯值粘贴、不保存关闭源文件的原有规则。

改造后完整代码 #

Sub Import_QTN_Data()
    Dim FileToOpen As Variant
    Dim OpenBook As Workbook
    Dim sourceMatchVal As Variant
    Dim matchRng As Range
    Dim targetSht As Worksheet
    
    Application.ScreenUpdating = False
  
    FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen <> False Then
        Set targetSht = ThisWorkbook.ActiveSheet
        Set OpenBook = Application.Workbooks.Open(FileToOpen)
        
        With OpenBook.Worksheets("QUOTATION")
            sourceMatchVal = .Range("T2").Value
            .Range("U2:AH2").Copy
        End With
        
        ' 在D列精确匹配目标值
        Set matchRng = targetSht.Columns("D:D").Find(What:=sourceMatchVal, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
        
        If Not matchRng Is Nothing Then
            ' 匹配成功，从对应行E列开始粘贴
            targetSht.Cells(matchRng.Row, "E").PasteSpecial xlPasteValues, skipblanks:=True
        Else
            MsgBox "未在当前活动工作表D列找到匹配值：" & sourceMatchVal, vbExclamation
        End If
        
        Application.CutCopyMode = False
        OpenBook.Close False
    End If

    Application.ScreenUpdating = True
End Sub

关键改动说明 #

• 取消原代码固定写入QUOTATION表E30的逻辑，自动捕获当前打开的活动工作表作为粘贴目标
• 新增值匹配逻辑：读取源文件T2单元格的匹配标识，在目标表D列做全值精确匹配，避免模糊匹配导致的行错位
• 粘贴位置自动对齐：找到匹配行后，从该行E列开始写入数据，和原逻辑的列起始位置一致，保证导入数据的列对应关系正确
• 新增匹配失败提示，找不到对应行时明确告知用户匹配值，方便排查问题
• 补充剪贴板清空操作，避免宏运行后残留复制选中状态

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