VBA实现大型数据集快速查找匹配 避免Excel卡顿崩溃

问题原因 #

你原来的代码使用双层嵌套循环，4万行数据匹配2.5万行的场景下会产生10亿次左右的比对运算，同时循环中直接操作单元格写入，这两个是导致运行慢、Excel崩溃的核心原因。

优化方案（使用字典实现极速匹配） #

字典的存在性检查效率远高于嵌套循环，同时我们把结果先存入数组，最后一次性写入单元格，大幅减少IO操作，10秒内就能跑完所有数据。

优化后代码 #

Sub MatchUser()
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    ' 不区分大小写的话可以加下面这行，需要区分就删掉
    ' dict.CompareMode = vbTextCompare
    
    Dim varr As Variant, i As Long
    ' 先把工作簿2的所有唯一值存入字典
    With userws1
        varr = .Range("A4:A" & .Range("A" & .Rows.Count).End(xlUp).Row).Value
    End With
    For i = 1 To UBound(varr, 1)
        If Not dict.exists(varr(i, 1)) Then
            dict.Add varr(i, 1), ""
        End If
    Next i
    
    Dim arr As Variant, resArr As Variant
    ' 读取工作簿1的A列数据，同时创建结果数组
    With AAws1
        arr = .Range("A4:A" & .Range("A" & .Rows.Count).End(xlUp).Row).Value
        ReDim resArr(1 To UBound(arr, 1), 1 To 1) ' 结果数组和A列行数一致
    End With
    
    ' 遍历工作簿1的每一个值，查字典
    For i = 1 To UBound(arr, 1)
        If dict.exists(arr(i, 1)) Then
            resArr(i, 1) = "user_found"
        Else
            resArr(i, 1) = "Not found"
        End If
    Next i
    
    ' 一次性把结果写入工作簿1的B列，如果你原需求是写入D列，把B4改成D4即可
    AAws1.Range("B4").Resize(UBound(resArr, 1), 1).Value = resArr
    
    ' 释放内存
    Set dict = Nothing
End Sub

注意事项 #

• 运行前确保AAws1和userws1两个工作表对象已经正确赋值，和你原来的代码保持一致即可
• 如果匹配时允许字母大小写不敏感，取消dict.CompareMode = vbTextCompare行的注释即可

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