Excel VBA 跨双工作表Vlookup匹配填充新零件号对应折扣码求助

你此前使用的=XLOOKUP(D2,Sheet1!A:A & Sheet2!A:A,B:B,0,1)存在两个核心问题：一是查找值错误写为待填充的D列空单元格，二是XLOOKUP不支持直接拼接两个整列作为查找范围，因此无法实现跨两表全匹配的需求。以下是可直接使用的VBA方案：

操作步骤 #

• 打开目标Excel工作簿，按Alt + F11调出VBA编辑器
• 在左侧工程资源管理器右键点击当前工作簿名称，依次选择「插入」-「模块」
• 将下方代码完整粘贴到模块的编辑区域
• 按F5运行代码即可完成填充

Sub 填充新零件号折扣码()
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    Dim ws As Worksheet, lastRow As Long, i As Long
    
    ' 先将两个工作表所有零件号与对应折扣码存入字典，方便后续快速匹配
    For Each ws In ThisWorkbook.Worksheets(Array("Sheet1", "Sheet2"))
        lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        ' 假设第1行为表头，从第2行开始遍历，如非表头请修改下方i的起始值
        For i = 2 To lastRow
            If Not dict.exists(ws.Cells(i, "A").Value) Then
                dict.Add ws.Cells(i, "A").Value, ws.Cells(i, "B").Value
            End If
        Next i
    Next ws
    
    ' 遍历两个表的C列，有新零件号的行匹配折扣码填充到D列
    For Each ws In ThisWorkbook.Worksheets(Array("Sheet1", "Sheet2"))
        lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
        For i = 2 To lastRow
            If Trim(ws.Cells(i, "C").Value) <> "" Then
                If dict.exists(ws.Cells(i, "C").Value) Then
                    ws.Cells(i, "D").Value = dict(ws.Cells(i, "C").Value)
                Else
                    ' 匹配不到时的提示内容可自行修改
                    ws.Cells(i, "D").Value = "无对应折扣码"
                End If
            End If
        Next i
    Next ws
    
    Set dict = Nothing
    MsgBox "折扣码填充操作完成"
End Sub

注意事项 #

• 如果你的工作表名称不是默认的Sheet1、Sheet2，请修改代码中Array("Sheet1", "Sheet2")内的工作表名称，和实际名称保持一致
• 如果你的表格表头不是第1行，把代码中两处For i = 2 To lastRow的数字2修改为你实际的数据起始行号即可
• 运行代码前请提前备份原文件，避免误操作导致数据丢失

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