VBA代码无报错却在710行停止，计数异常求助

问题现象 #

• 代码运行无报错，但执行到第710行时停止
• 手动确认目标字符串"Encours"仅存在83次，代码却统计出201次，即便设置了找到200次后退出的逻辑仍无法理解
• 当前工作表无隐藏行、合并单元格，已设置搜索所有错误类型

原代码 #

Sub Test_Calcules()
    
    Dim searchString As String
    Dim foundRange As Range
    Dim sumRange As Range
    Dim lastRow As Long
    Dim formulaString As String
    Dim numStringsFound As Long
    Dim lastSumRow As Long ' new variable to keep track of the last row where the sum was calculated
    Dim risqueRange As Range ' new variable to hold the range for the Risque PTF formula
    Dim sumFormula As String ' new variable to hold the Sum formula
    Dim sumProductFormula As String ' new variable to hold the Sumproduct formula
    Dim sumValue As Double ' new variable to hold the sum of the Sum formula
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    searchString = "Encours" ' change to your specific string
    numStringsFound = 0
    lastSumRow = 0 ' initialize the lastSumRow variable to 0
   
    With ActiveSheet
        lastRow = .Cells(.Rows.count, "I").End(xlUp).Row ' get last row in column I
        Set foundRange = .Range("I:I").Find(What:=searchString, LookIn:=xlValues, LookAt:=xlWhole) ' search for the string in column I
        If Not foundRange Is Nothing Then
            firstAddress = foundRange.Address
            Do
                Set foundRange = .Range("I:I").FindNext(foundRange)
            Loop While Not foundRange Is Nothing And foundRange.Address <> firstAddress
        End If
        Do While Not foundRange Is Nothing ' if the string is found, continue
            numStringsFound = numStringsFound + 1
            If numStringsFound > 200 Then
                 Exit Do
            End If
            
            If foundRange.Row > lastSumRow Then ' check if the current row is greater than the last row where the sum was calculated
                Set sumRange = .Range("B" & foundRange.Row + 1, "B" & foundRange.End(xlDown).Row) ' select the range to sum
                sumFormula = "=ROUND(SUM(B" & foundRange.Row + 1 & ":B" & foundRange.End(xlDown).Row & ") ,0)" ' create Sum formula string
                foundRange.Offset(1, 0).formula = sumFormula ' enter formula in the cell below the search string
                sumValue = foundRange.Offset(1, 0).Value ' get the sum value for the Sumproduct formula
                lastSumRow = foundRange.End(xlDown).Row ' update the lastSumRow variable to the last row where the sum was calculated
                Set risqueRange = foundRange.Offset(0, 1).Resize(sumRange.Rows.count, 1) ' set the range for the Risque PTF formula
                sumProductFormula = "=IFERROR((SUMPRODUCT(" & sumRange.Address & "," & sumRange.Offset(0, 4).Address & ")/(" & sumValue & ")),)" ' create Sumproduct formula string
                risqueRange.Offset(1, 0).Cells(1, 1).formula = sumProductFormula ' enter formula in the cell below the Risque PTF string
                lastSumRow = risqueRange.End(xlDown).Row ' update the lastSumRow variable to the last row where the sum was calculated
                Set foundRange = .Range(foundRange.Offset(1, 0), .Cells(lastRow, "I")).Find(What:=searchString, LookIn:=xlValues, LookAt:=xlWhole) ' find the next occurrence of the search string
            End If
        Loop
    End With
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
   
    MsgBox "Found " & numStringsFound & " instances of the search string."
End Sub

问题原因 #

1. 初始查找逻辑无效：
   代码开头的Do-Loop循环反复调用FindNext，直到回到第一个匹配单元格地址才退出，此时foundRange被重置为第一个匹配项，后续主循环会从重复起点开始计数，直接导致统计异常。

2. 重复计数死循环：
   当foundRange.Row <= lastSumRow时，代码不会执行查找下一个匹配项的逻辑，foundRange始终指向同一个单元格，numStringsFound会持续递增，直到达到200次触发退出条件，这就是统计出201次的核心原因。同时，这种重复循环会导致代码在第710行（Do While Not foundRange Is Nothing）处持续运行，直到触发退出逻辑。

修正后的代码 #

Sub Test_Calcules()
    
    Dim searchString As String
    Dim foundRange As Range
    Dim sumRange As Range
    Dim lastRow As Long
    Dim numStringsFound As Long
    Dim lastSumRow As Long
    Dim risqueRange As Range
    Dim sumFormula As String
    Dim sumProductFormula As String
    Dim sumValue As Double
    Dim firstAddress As String ' 声明firstAddress变量
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    searchString = "Encours"
    numStringsFound = 0
    lastSumRow = 0
   
    With ActiveSheet
        lastRow = .Cells(.Rows.Count, "I").End(xlUp).Row
        Set foundRange = .Range("I:I").Find(What:=searchString, LookIn:=xlValues, LookAt:=xlWhole)
        
        If Not foundRange Is Nothing Then
            firstAddress = foundRange.Address
            Do
                numStringsFound = numStringsFound + 1
                If numStringsFound > 200 Then Exit Do
                
                If foundRange.Row > lastSumRow Then
                    ' 处理Sum公式
                    Set sumRange = .Range("B" & foundRange.Row + 1, "B" & foundRange.End(xlDown).Row)
                    sumFormula = "=ROUND(SUM(" & sumRange.Address & ") ,0)"
                    foundRange.Offset(1, 0).Formula = sumFormula
                    sumValue = foundRange.Offset(1, 0).Value
                    
                    ' 处理Sumproduct公式
                    Set risqueRange = foundRange.Offset(0, 1).Resize(sumRange.Rows.Count, 1)
                    sumProductFormula = "=IFERROR((SUMPRODUCT(" & sumRange.Address & "," & sumRange.Offset(0, 4).Address & ")/" & sumValue & "),)"
                    risqueRange.Offset(1, 0).Cells(1, 1).Formula = sumProductFormula
                    
                    lastSumRow = foundRange.End(xlDown).Row
                End If
                
                ' 查找下一个匹配项
                Set foundRange = .Range("I:I").FindNext(foundRange)
                ' 防止循环回到第一个匹配项
                If foundRange.Address = firstAddress Then Exit Do
                
            Loop While Not foundRange Is Nothing
        End If
    End With
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
   
    MsgBox "Found " & numStringsFound & " instances of the search string."
End Sub

修正说明 #

• 移除初始无效的Do-Loop循环，改用标准Find+FindNext循环逻辑
• 添加firstAddress变量声明，防止回到第一个匹配项时无限循环
• 将计数逻辑整合到主循环，确保每个匹配项仅被统计一次
• 优化查找逻辑，避免重复处理同一单元格导致的死循环

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