VBA加载项循环随迭代次数增加运行速度骤降求助

兄弟，你这代码的性能问题我太熟了——典型的“小循环快，大循环崩”，完全是踩了Excel VBA的几个经典性能陷阱！我帮你拆解下问题，再给你一套优化方案，保证200次循环从数小时缩到几分钟甚至更短：

核心性能瓶颈分析 #

• 重复读取固定数据：你每次外层循环都重新读取accArray = sh.Range("A2:A" & lRow).Value，这数据其实是固定不变的，反复读取完全是浪费时间，次数越多累积的开销越大。
• 过度依赖工作表交互：每次循环都做AutoFilter排序、复制粘贴、选择单元格这些操作，Excel的界面渲染和对象操作开销极大，200次循环下来这些操作的耗时会指数级增长（毕竟每次操作都要刷新界面）。
• 不必要的DoEvents调用：每次循环都调用DoEvents，虽然能让进度条动，但也会让Excel频繁切换到消息循环，增加额外开销，尤其是循环次数多的时候影响更明显。
• 冗余的Select/Selection操作：sh.Select、CoAsh.Select这些完全没必要，直接操作单元格对象就行，选中单元格是给人看的，代码里这么做只会拖慢速度。

优化后的代码 #

Sub OptimizedMatch()
    Dim CoAsh As Worksheet, sh As Worksheet
    Dim matchRange As Range, rRow As Range
    Dim accArray As Variant, levResults As Variant
    Dim sortedIndices As Variant, topUnique As Collection
    Dim i As Long, rowCount As Long, lRow As Long
    Dim pctDone As Double, AccCol As Long
    Dim currentAcc As String, accString As String
    Dim b As Long, idx As Long, uniqueCount As Long
    
    ' 请根据你的实际情况提前赋值以下变量
    ' Set CoAsh = ThisWorkbook.Worksheets("CoAsh")
    ' Set sh = ThisWorkbook.Worksheets("你的工作表名称")
    ' lRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
    ' rowCount = matchRange.Rows.Count
    ' AccCol = 目标列的列号（比如A列是1）
    
    ' 一次性读取固定的账户数组，仅执行一次
    accArray = sh.Range("A2:A" & lRow).Value
    ' 初始化存储Levenshtein距离的结果数组
    ReDim levResults(1 To UBound(accArray, 1), 1 To 1)
    
    ' 关闭Excel后台消耗性能的功能，大幅提速
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    i = 1
    For Each rRow In CoAsh.Range(matchRange.Address).Rows
        pctDone = i / rowCount
        ' 每5次循环更新一次进度条，减少DoEvents的开销
        If i Mod 5 = 0 Then
            With frmProgress
                .LabelCaption.Caption = "Processing account " & i & " of " & rowCount
                .LabelProgress.Width = pctDone * (.FrameProgress.Width)
                .LabelPercent = Round(pctDone * 100, 0) & "%"
            End With
            DoEvents
        End If
        
        currentAcc = CoAsh.Cells(rRow.Row, AccCol).Value
        ' 在内存数组中计算Levenshtein距离，不直接操作工作表
        For b = LBound(accArray) To UBound(accArray)
            accString = accArray(b, 1)
            levResults(b, 1) = levenshtein(currentAcc, accString, True)
        Next b
        
        ' 通过数组排序获取前5个最大距离的索引，替代AutoFilter操作
        sortedIndices = GetSortedIndices(levResults, xlDescending)
        
        ' 在内存中去重，用Collection的Key特性实现，避免工作表操作
        Set topUnique = New Collection
        uniqueCount = 0
        For idx = 1 To UBound(sortedIndices)
            On Error Resume Next
            topUnique.Add accArray(sortedIndices(idx), 1), Key:=CStr(accArray(sortedIndices(idx), 1))
            On Error GoTo 0
            uniqueCount = uniqueCount + 1
            If uniqueCount >= 5 Then Exit For
        Next idx
        
        ' 将去重后的结果批量写入目标单元格，直接赋值无需复制粘贴
        Dim resultArr As Variant
        ReDim resultArr(1 To topUnique.Count)
        For idx = 1 To topUnique.Count
            resultArr(idx) = topUnique(idx)
        Next idx
        CoAsh.Cells(rRow.Row, 8).Resize(1, topUnique.Count).Value = resultArr
        
        i = i + 1
    Next rRow
    
    ' 恢复Excel的默认设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
    ' 最后更新进度条显示完成
    With frmProgress
        .LabelCaption.Caption = "Processing complete!"
        .LabelProgress.Width = .FrameProgress.Width
        .LabelPercent = "100%"
    End With
    DoEvents
End Sub

' 辅助函数：返回数组的排序索引（支持升序/降序），避免操作工作表排序
Function GetSortedIndices(arr As Variant, sortOrder As XlSortOrder) As Variant
    Dim indices As Variant, i As Long, j As Long, temp As Long
    
    ReDim indices(1 To UBound(arr, 1))
    For i = 1 To UBound(arr, 1)
        indices(i) = i
    Next i
    
    ' 数据量不大时冒泡排序足够用，数据量极大可替换为更高效的排序算法
    For i = 1 To UBound(indices) - 1
        For j = i + 1 To UBound(indices)
            If (sortOrder = xlDescending And arr(indices(i), 1) < arr(indices(j), 1)) Or _
               (sortOrder = xlAscending And arr(indices(i), 1) > arr(indices(j), 1)) Then
                temp = indices(i)
                indices(i) = indices(j)
                indices(j) = temp
            End If
        Next j
    Next i
    
    GetSortedIndices = indices
End Function

关键优化点说明 #

• 一次性读取固定数据：把accArray的读取移到外层循环外，仅执行一次，避免重复的工作表IO操作。
• 内存数组替代工作表操作：所有计算（距离计算、排序、去重）都在内存数组中完成，完全规避了AutoFilter、复制粘贴这些慢操作。
• 批量更新进度条：每隔几次循环才更新进度条并调用DoEvents，减少界面交互的开销。
• 关闭Excel后台功能：关闭ScreenUpdating、Calculation、EnableEvents后，Excel不会在代码运行时刷新界面、自动计算或触发事件，速度会提升数倍。
• 移除所有Select/Selection：直接操作单元格对象，无需选中单元格，减少不必要的界面交互。
• 内存中去重：利用Collection的Key特性实现去重，无需将数据写入工作表再处理，节省大量时间。

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