同一工作簿不同工作表列数据校验VBA代码优化求助

原代码性能差&结果缺失的核心原因 #

• 双重循环嵌套+逐单元格读写：3500行数据会触发千万级的单元格操作，IO开销极高，是运行缓慢的核心原因
• 用UBound(Filter(finishedcounting, tempcountingRow))判断匹配状态：每次遍历都要扫描整个数组，额外增加了大量计算开销
• End(xlDown)取行数逻辑：如果B列中间存在空单元格，会提前截断统计的行数，导致后续数据未参与比对，就是结果缺失的直接原因
• 变量声明不规范：多变量同时声明时，未指定类型的变量会被默认设为Variant，额外增加运行开销

优化后代码 #

优化核心是用Dictionary字典做匹配索引，所有数据提前读入内存数组操作，3500行数据运行耗时可以控制在1秒以内。
使用前可选择两种字典启用方式：

1. 按Alt+F11打开VBA编辑器，点击【工具】-【引用】，勾选「Microsoft Scripting Runtime」
2. 不想手动引用的话，直接用代码里的CreateObject动态创建写法即可

Public Sub Compare_sheets_Optimized()
    Dim targetSheet As Worksheet, countingSheet As Worksheet, outputSheet As Worksheet
    Dim startRow As Integer, outputRow As Integer, i As Long
    Dim targetArr As Variant, countingArr As Variant, outputArr As Variant
    Dim countDict As Object
    Dim maxOutputRow As Long
    
    '关闭屏幕刷新、事件、自动计算，最大化运行效率
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    '初始化工作表
    Set outputSheet = Sheets("Compare Sheets")
    Set targetSheet = Sheets(outputSheet.Range("C3").Value)
    Set countingSheet = Sheets(outputSheet.Range("C4").Value)
    startRow = 3
    outputRow = 1 '数组下标从1开始
    
    '创建字典，存储counting表B列的值和对应行数据
    Set countDict = CreateObject("Scripting.Dictionary")
    '读取counting表所有有效数据到数组，用UsedRange避免空行截断问题
    With countingSheet
        countingArr = .Range(.Cells(startRow, "B"), .Cells(.UsedRange.Rows.Count, "C")).Value
    End With
    For i = 1 To UBound(countingArr)
        '跳过空行，key存B列值，item存对应的C列值
        If countingArr(i, 1) <> vbNullString And Not countDict.Exists(countingArr(i, 1)) Then
            countDict(countingArr(i, 1)) = countingArr(i, 2)
        End If
    Next i
    
    '读取target表有效数据到数组
    With targetSheet
        targetArr = .Range(.Cells(startRow, "B"), .Cells(.UsedRange.Rows.Count, "D")).Value
    End With
    '预定义输出数组，最大长度为两张表行数总和，避免多次扩容
    maxOutputRow = UBound(targetArr) + UBound(countingArr)
    ReDim outputArr(1 To maxOutputRow, 1 To 5) '对应F到J列，共5列
    
    '遍历target表数据，匹配字典
    For i = 1 To UBound(targetArr)
        If targetArr(i, 1) = vbNullString Then GoTo nextTarget '跳过空行
        outputArr(outputRow, 2) = targetArr(i, 1) 'G列：B列值
        outputArr(outputRow, 3) = targetArr(i, 2) 'H列：C列值
        outputArr(outputRow, 4) = targetArr(i, 3) 'I列：D列值
        If countDict.Exists(targetArr(i, 1)) Then
            outputArr(outputRow, 1) = "FOUND" 'F列状态
            countDict.Remove targetArr(i, 1) '匹配成功后移除字典项，后续统计新增直接遍历剩下的
        Else
            outputArr(outputRow, 1) = "MISSING"
        End If
        outputRow = outputRow + 1
nextTarget:
    Next i
    
    '遍历字典剩余项，就是counting表新增的数据
    Dim key As Variant
    For Each key In countDict.Keys
        outputArr(outputRow, 1) = "ADDITIONAL"
        outputArr(outputRow, 2) = key 'G列：B列值
        outputArr(outputRow, 5) = countDict(key) 'J列：C列值
        outputRow = outputRow + 1
    Next key
    
    '清空旧结果，把输出数组一次性写入工作表
    outputSheet.Range("F2:J" & outputSheet.UsedRange.Rows.Count).ClearContents
    outputSheet.Range("F2").Resize(UBound(outputArr, 1), UBound(outputArr, 2)).Value = outputArr
    
    '恢复Excel默认设置
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

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