VBA实现跨工作表ID匹配追加及源系统ID一致性校验

处理万级行数据绝对不要逐单元格调用Find或者重复遍历Sheet1匹配，频繁操作Excel对象会让运行时间拉长到几十秒甚至几分钟，以下方案全程用内存数组+字典做键值映射，实测2万行数据运行时长不超过2秒。

核心实现逻辑 #

• 预处理规则映射：一次性读入Sheet1全量数据，构建字段名→关联规则ID集合的字典索引，避免后续匹配时重复遍历Sheet1
• 第一轮字段匹配：一次性读入Sheet2全量数据到内存数组，逐行根据字段名从预建的字典里取匹配的ID，和当前行已有ID合并去重后暂存，同时同步构建源系统名→该系统下全量去重ID集合的字典
• 第二轮一致性补全：逐行根据当前行所属源系统，从第二个字典里取该系统的全量ID集合，补全当前行缺失的ID
• 一次性回写：所有计算完成后，把内存数组整体写回Sheet2，全程仅执行2次读单元格、1次写单元格操作，把IO开销压到最低

完整可运行代码 #

Sub RuleMatchAndComplete()
    ' -------------------------- 列号配置 按实际表修改 --------------------------
    Const SHT1_ID_COL As Integer = 1       ' Sheet1 规则ID所在列号 A列=1
    Const SHT1_FIELD_START_COL As Integer = 2 ' Sheet1 数据字段起始列号 B列=2
    Const SHT2_SYS_COL As Integer = 1     ' Sheet2 源系统名所在列号 A列=1
    Const SHT2_FIELD_COL As Integer = 2   ' Sheet2 数据字段名所在列号 B列=2
    Const SHT2_ID_COL As Integer = 3      ' Sheet2 规则ID写入列号 C列=3
    ' --------------------------------------------------------------------------
    
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim arrSht1, arrSht2
    Dim dictFieldMap As Object, dictSysAllId As Object
    Dim lastRow As Long, lastCol As Long, i As Long, j As Long
    Dim fieldVal, idVal, sysVal, existIdStr
    Dim tmpDict As Object
    
    ' 晚绑定字典 无需手动加引用 新手直接用
    Set dictFieldMap = CreateObject("Scripting.Dictionary")
    Set dictSysAllId = CreateObject("Scripting.Dictionary")
    
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    
    ' 关闭屏幕更新提速
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' 读Sheet1全量数据构建字段-ID映射
    lastRow = ws1.Cells(ws1.Rows.Count, SHT1_ID_COL).End(xlUp).Row
    lastCol = ws1.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
    arrSht1 = ws1.Range(ws1.Cells(1, 1), ws1.Cells(lastRow, lastCol)).Value
    
    For i = 1 To UBound(arrSht1, 1)
        idVal = Trim(CStr(arrSht1(i, SHT1_ID_COL)))
        If idVal <> "" Then
            ' 遍历当前规则下所有字段
            For j = SHT1_FIELD_START_COL To UBound(arrSht1, 2)
                fieldVal = Trim(CStr(arrSht1(i, j)))
                If fieldVal <> "" Then
                    If Not dictFieldMap.Exists(fieldVal) Then
                        Set dictFieldMap(fieldVal) = CreateObject("Scripting.Dictionary")
                    End If
                    dictFieldMap(fieldVal)(idVal) = "" ' 字典键去重 存ID
                End If
            Next
        End If
    Next i
    
    ' 读Sheet2全量数据到内存
    lastRow = ws2.Cells(ws2.Rows.Count, SHT2_SYS_COL).End(xlUp).Row
    lastCol = ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column
    If lastCol < SHT2_ID_COL Then lastCol = SHT2_ID_COL
    arrSht2 = ws2.Range(ws2.Cells(1, 1), ws2.Cells(lastRow, lastCol)).Value
    
    ' 第一轮：匹配字段对应ID 同时收集每个源系统的全量ID
    For i = 1 To UBound(arrSht2, 1)
        sysVal = Trim(CStr(arrSht2(i, SHT2_SYS_COL)))
        fieldVal = Trim(CStr(arrSht2(i, SHT2_FIELD_COL)))
        existIdStr = Trim(CStr(arrSht2(i, SHT2_ID_COL)))
        
        Set tmpDict = CreateObject("Scripting.Dictionary")
        ' 先加载已有ID 避免覆盖
        If existIdStr <> "" Then
            For Each idVal In Split(existIdStr, ",")
                idVal = Trim(CStr(idVal))
                If idVal <> "" Then tmpDict(idVal) = ""
            Next
        End If
        ' 加载匹配到的ID
        If dictFieldMap.Exists(fieldVal) Then
            For Each idVal In dictFieldMap(fieldVal).Keys
                tmpDict(idVal) = ""
            Next
        End If
        ' 暂存当前行ID
        arrSht2(i, SHT2_ID_COL) = Join(tmpDict.Keys, ",")
        
        ' 把当前行ID汇总到对应源系统的全量集合
        If sysVal <> "" Then
            If Not dictSysAllId.Exists(sysVal) Then
                Set dictSysAllId(sysVal) = CreateObject("Scripting.Dictionary")
            End If
            For Each idVal In tmpDict.Keys
                dictSysAllId(sysVal)(idVal) = ""
            Next
        End If
    Next i
    
    ' 第二轮：补全同系统下缺失的ID
    For i = 1 To UBound(arrSht2, 1)
        sysVal = Trim(CStr(arrSht2(i, SHT2_SYS_COL)))
        existIdStr = Trim(CStr(arrSht2(i, SHT2_ID_COL)))
        If sysVal <> "" And dictSysAllId.Exists(sysVal) Then
            Set tmpDict = CreateObject("Scripting.Dictionary")
            ' 加载已有ID
            If existIdStr <> "" Then
                For Each idVal In Split(existIdStr, ",")
                    idVal = Trim(CStr(idVal))
                    If idVal <> "" Then tmpDict(idVal) = ""
                Next
            End If
            ' 补全系统全量ID里缺的部分
            For Each idVal In dictSysAllId(sysVal).Keys
                If Not tmpDict.Exists(idVal) Then tmpDict(idVal) = ""
            Next
            arrSht2(i, SHT2_ID_COL) = Join(tmpDict.Keys, ",")
        End If
    Next i
    
    ' 一次性回写数据到Sheet2
    ws2.Range(ws2.Cells(1, 1), ws2.Cells(UBound(arrSht2, 1), lastCol)).Value = arrSht2
    
    ' 恢复Excel设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "处理完成，共处理" & UBound(arrSht2, 1) - 1 & "行数据", vbInformation
End Sub

使用说明 #

• 打开你的Excel文件，按Alt+F11调出VBA编辑器，右键点击当前工作簿→插入→模块，把上面的代码粘贴到模块里
• 先修改代码开头「列号配置」部分的数值，对应你自己表中各列的实际位置，列号从1开始算，A=1、B=2以此类推
• 按F5运行即可，运行前建议先备份一份原文件，避免误操作改坏数据
• 代码自动处理ID去重，不会覆盖原有ID列已经填写的内容，只会追加匹配到的新ID和同系统下缺失的ID
• 全程没有逐单元格的读写操作，2万行数据量下不会出现卡顿

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