如何用VBA实现Excel多工作表Lookup并将结果输出至第三张表

阿华AIGC实验室

2026-5-26

Excel VBA 跨工作表Lookup实现方案

嘿，我来帮你搞定这个跨工作表的Lookup需求！根据你给出的Sheet1和Sheet2数据结构，我们需要匹配Sheet1的变更编号与Sheet2的客户参考ID，把对应的工单编号和Sheet1的日期一并输出到第三张工作表（Sheet3）里。下面给你两种实现方式，分别适合小数据量和大数据量场景：

方案一：双重循环匹配（适合小数据量）

这种方式逻辑直观，适合数据行数不多的情况，代码容易理解和调试：

Sub LookupBetweenSheets()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long, i As Long, j As Long
    Dim matchFound As Boolean
    
    ' 绑定工作表对象
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    
    ' 检查Sheet3是否存在，不存在则新建
    On Error Resume Next
    Set ws3 = ThisWorkbook.Sheets("Sheet3")
    If Err.Number <> 0 Then
        Set ws3 = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        ws3.Name = "Sheet3"
    End If
    On Error GoTo 0
    
    ' 写入Sheet3表头
    ws3.Range("A1").Value = "变更编号"
    ws3.Range("B1").Value = "日期"
    ws3.Range("C1").Value = "匹配工单编号"
    
    ' 获取两个工作表的最后数据行号
    lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.Count, "B").End(xlUp).Row
    
    ' 遍历Sheet1的每一行数据（跳过表头）
    For i = 2 To lastRow1
        matchFound = False
        ' 遍历Sheet2找匹配项
        For j = 2 To lastRow2
            If ws1.Cells(i, "A").Value = ws2.Cells(j, "B").Value Then
                ' 写入匹配结果到Sheet3
                ws3.Cells(i, "A").Value = ws1.Cells(i, "A").Value
                ws3.Cells(i, "B").Value = ws1.Cells(i, "B").Value
                ws3.Cells(i, "C").Value = ws2.Cells(j, "A").Value
                matchFound = True
                Exit For ' 找到匹配就跳出内层循环，节省时间
            End If
        Next j
        
        ' 无匹配时标记提示
        If Not matchFound Then
            ws3.Cells(i, "A").Value = ws1.Cells(i, "A").Value
            ws3.Cells(i, "B").Value = ws1.Cells(i, "B").Value
            ws3.Cells(i, "C").Value = "无匹配"
        End If
    Next i
    
    ' 自动调整列宽优化显示
    ws3.Columns.AutoFit
    
    MsgBox "Lookup完成！结果已写入Sheet3。", vbInformation
End Sub

方案二：字典匹配（适合大数据量）

如果你的数据行数很多（比如上千行），双重循环会比较慢，用Scripting.Dictionary可以大幅提升效率，因为字典是键值对存储，查找速度是O(1)：

Sub LookupWithDictionary()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long, i As Long
    Dim dict As Object
    
    ' 绑定工作表对象
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    
    ' 处理Sheet3的创建/获取
    On Error Resume Next
    Set ws3 = ThisWorkbook.Sheets("Sheet3")
    If Err.Number <> 0 Then
        Set ws3 = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        ws3.Name = "Sheet3"
    End If
    On Error GoTo 0
    
    ' 写入表头
    ws3.Range("A1:C1").Value = Array("变更编号", "日期", "匹配工单编号")
    
    ' 创建字典对象，存储客户参考ID与工单编号的映射
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 遍历Sheet2，把数据存入字典
    lastRow2 = ws2.Cells(ws2.Rows.Count, "B").End(xlUp).Row
    For i = 2 To lastRow2
        ' 避免重复键，若有相同客户参考ID，保留最后一条工单编号
        If Not dict.Exists(ws2.Cells(i, "B").Value) Then
            dict.Add ws2.Cells(i, "B").Value, ws2.Cells(i, "A").Value
        Else
            dict(ws2.Cells(i, "B").Value) = ws2.Cells(i, "A").Value
        End If
    Next i
    
    ' 遍历Sheet1，从字典快速查找匹配
    lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    For i = 2 To lastRow1
        ws3.Cells(i, "A").Value = ws1.Cells(i, "A").Value
        ws3.Cells(i, "B").Value = ws1.Cells(i, "B").Value
        
        ' 检查字典中是否存在对应变更编号
        If dict.Exists(ws1.Cells(i, "A").Value) Then
            ws3.Cells(i, "C").Value = dict(ws1.Cells(i, "A").Value)
        Else
            ws3.Cells(i, "C").Value = "无匹配"
        End If
    Next i
    
    ' 自动调整列宽
    ws3.Columns.AutoFit
    
    MsgBox "高效Lookup完成！结果已写入Sheet3。", vbInformation
End Sub