Excel VBA实现跨工作表查询结果粘贴为静态值需求求助

Sub 匹配填充静态值()
    Dim dict As Object
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long
    Dim i As Long
    Dim searchKey As Variant
    
    ' 定义工作表对象
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    ' 初始化字典存储Sheet2的匹配关系：key为B列值，item存储对应A、G列的值
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 获取Sheet2 B列最后一行行号
    lastRow2 = ws2.Cells(ws2.Rows.Count, "B").End(xlUp).Row
    ' 遍历Sheet2所有有效行，将匹配关系存入字典
    For i = 1 To lastRow2
        searchKey = ws2.Cells(i, "B").Value
        If Not dict.exists(searchKey) Then
            ' 数组第一个元素存A列值，第二个存G列值
            dict(searchKey) = Array(ws2.Cells(i, "A").Value, ws2.Cells(i, "G").Value)
        End If
    Next i
    
    ' 获取Sheet1 B列最后一行行号
    lastRow1 = ws1.Cells(ws1.Rows.Count, "B").End(xlUp).Row
    ' 从第10行开始遍历Sheet1 B列，匹配填充A、C列
    For i = 10 To lastRow1
        searchKey = ws1.Cells(i, "B").Value
        If dict.exists(searchKey) Then
            ws1.Cells(i, "A").Value = dict(searchKey)(0)
            ws1.Cells(i, "C").Value = dict(searchKey)(1)
        Else
            ' 未匹配到的场景可自定义赋值逻辑，默认留空
            ws1.Cells(i, "A").Value = ""
            ws1.Cells(i, "C").Value = ""
        End If
    Next i
    
    ' 释放对象
    Set dict = Nothing
    Set ws1 = Nothing
    Set ws2 = Nothing
End Sub

使用步骤 #

• 打开目标Excel文件后按Alt + F11调出VBA编辑器
• 右键点击左侧工程栏的当前工作簿名称，选择「插入」-「模块」
• 将上述代码粘贴到模块编辑窗口
• 按F5直接运行，也可绑定到表格按钮触发运行

特性说明 #

• 填充到Sheet1 A、C列的所有内容均为静态数值，无任何公式，不会干扰其余代码运行
• 采用字典匹配逻辑，数据量较大时运行效率远高于逐行遍历查找
• 重复匹配逻辑和XLOOKUP默认规则一致，取Sheet2 B列第一个匹配项的对应值
• 未匹配到值时A、C列默认留空，可按需修改代码Else分支的赋值规则

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