如何终止已排序数据透视表的Sumproduct VBA宏循环

原代码针对排序后的透视表计算加权平均，但内层循环会遍历所有行，浪费性能。利用数据已按A列、B列排序的特性，遇到第一个不匹配项即可终止内层循环，修改后的代码如下：

Sub weighted_averagek()
    Dim sh As Worksheet, arrI As Variant, arrF As Variant, lastR As Long
    Dim i As Long, j As Long, pCount As Double, d As Object, pcount2 As Double, pcount3 As Double

    Set sh = ActiveSheet
    lastR = sh.Range("A" & Cells.Rows.Count).End(xlUp).Row
    arrI = sh.Range("A2:F" & lastR).Value
    ReDim arrF(1 To UBound(arrI, 1), 1 To 1)
    Set d = CreateObject("Scripting.Dictionary")

    For i = 1 To UBound(arrI, 1)
        If Not d.Exists(UCase(arrI(i, 1) & arrI(i, 2))) Then
            ' 内层循环从i开始，利用排序特性只处理当前组的连续记录
            For j = i To UBound(arrI, 1)
                If UCase(arrI(i, 1)) = UCase(arrI(j, 1)) And arrI(i, 2) = arrI(j, 2) Then
                    On Error Resume Next ' 改用Resume Next处理除零错误，避免跳转影响循环逻辑
                    pCount = pCount + (arrI(j, 6) * arrI(j, 5))
                    pcount2 = pcount2 + arrI(j, 6)
                    pcount3 = pCount / pcount2
                    On Error GoTo 0 ' 恢复默认错误处理
                Else
                    ' 遇到不匹配项，直接终止内层循环（排序后后续不会再有匹配项）
                    Exit For
                End If
            Next j
            d(UCase(arrI(i, 1) & arrI(i, 2))) = pcount3
            arrF(i, 1) = pcount3: pcount3 = 0: pCount = 0: pcount2 = 0
        Else
            arrF(i, 1) = d(UCase(arrI(i, 1) & arrI(i, 2)))
        End If
    Next
    sh.Range("G2").Resize(UBound(arrF, 1), 1).Value = arrF
End Sub

关键修改说明： #

• 内层循环起始位置调整：将j的起始值从1改为i，因为数据已排序，当前组的记录从i开始连续排列，无需重复检查前面已处理过的行
• 添加循环终止逻辑：当j行的A/B列与i行不匹配时，执行Exit For终止内层循环，充分利用排序后同组记录连续的特性，减少无效遍历
• 优化错误处理：将On Error GoTo改为On Error Resume Next并配合On Error GoTo 0，避免错误跳转打乱循环终止逻辑，同时处理可能的除零错误

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