如何通过VBA提升跨多工作表查找联系人出现次数的代码运行速度

• 逐单元格循环写入公式，大范围下循环开销高，且每次写入都会触发自动计算
• 公式使用INDIRECT易失性函数+跨多表COUNTIF，每个单元格都要重复遍历所有周表的查询范围，重复计算量极高
• 仅关闭了事件未关闭自动计算，公式写入过程中反复重算进一步拖慢速度

适合需要保留公式动态更新能力的场景，无需修改原有计算逻辑：

Sub ContactCycle_Optimized()
    Dim WsMaster As Worksheet
    Dim WsLastRow As Long
    Dim MyContactCycleRange As Range
    
    ' 关闭不必要的功能提速
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set WsMaster = ThisWorkbook.Worksheets("Master")
    WsLastRow = WsMaster.Range("A" & WsMaster.Rows.Count).End(xlUp).Row
    Set MyContactCycleRange = WsMaster.Range("AB5:AB" & WsLastRow)
    
    ' 一次性给整个范围写入公式，无需循环
    MyContactCycleRange.Formula = "=IF(SUMPRODUCT(COUNTIF(INDIRECT(""'""&Weeks&""'!$A$6:$A$45""),$B5))>0,1,0)"
    
    ' 可选：如果不需要保留公式，取消下面注释直接转成值避免后续重算
    ' MyContactCycleRange.Value = MyContactCycleRange.Value
    
    ' 恢复设置
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

性能最优方案，仅需遍历一次所有周表的查询范围，通过字典缓存去重后批量匹配结果，完全不需要公式，万行数据也可秒出结果：

Sub ContactCycle_NoFormula()
    Dim WsMaster As Worksheet, ws As Worksheet
    Dim WsLastRow As Long, i As Long
    Dim nameDict As Object
    Dim arrB, arrRes
    
    ' 初始化字典存储所有周表出现过的合作伙伴名称
    Set nameDict = CreateObject("Scripting.Dictionary")
    
    ' 关闭不必要的功能提速
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' 第一步：遍历所有周表，把A6:A45的有效名称存入字典
    For Each ws In ThisWorkbook.Worksheets
        ' 匹配命名范围Weeks中的工作表
        If Not IsError(Application.Match(ws.Name, ThisWorkbook.Names("Weeks").RefersToRange, 0)) Then
            For i = 6 To 45
                If ws.Range("A" & i).Value <> "" Then
                    If Not nameDict.Exists(ws.Range("A" & i).Value) Then
                        nameDict(ws.Range("A" & i).Value) = True
                    End If
                End If
            Next i
        End If
    Next ws
    
    ' 第二步：批量匹配Master表的合作伙伴
    Set WsMaster = ThisWorkbook.Worksheets("Master")
    WsLastRow = WsMaster.Range("A" & WsMaster.Rows.Count).End(xlUp).Row
    ' 读入数组避免逐单元格读取开销
    arrB = WsMaster.Range("B5:B" & WsLastRow).Value
    ReDim arrRes(1 To UBound(arrB, 1), 1 To 1)
    
    For i = 1 To UBound(arrB, 1)
        arrRes(i, 1) = IIf(nameDict.Exists(arrB(i, 1)), 1, 0)
    Next i
    
    ' 一次性写入所有结果
    WsMaster.Range("AB5:AB" & WsLastRow).Value = arrRes
    
    ' 恢复设置
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Set nameDict = Nothing
End Sub

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