VBA For Each循环全速运行时导致Excel崩溃求助

核心问题推测 #

1. 低效重复判断导致内存爆炸：原代码用字符串拼接+InStr判断尾号重复，当数据量较大时，字符串会持续膨胀，VBA不可变字符串的特性会反复生成新对象，最终触发Excel内存崩溃。
2. 集合迭代的实时性冲突：自定义集合的默认迭代器是实时绑定的，全速运行时迭代速度快，若集合内部状态（如对象引用计数）未及时同步，会触发内存级错误，这类错误通常会绕过VBA的错误处理机制。
3. 隐式空引用风险：ff_table_line中直接访问Me.Aircraft的属性，若该对象为Nothing，会触发内存崩溃而非VBA可捕获的错误。

具体修复方案 #

1. 替换低效的重复判断逻辑 #

用Scripting.Dictionary替代字符串拼接，既提升效率，又避免内存激增：

Private Function ff_table() As String
    Dim flt As CFlight
    Dim s As String
    Dim acftDict As Object ' Scripting.Dictionary
    
    Set acftDict = CreateObject("Scripting.Dictionary")
    On Error GoTo ff_tableErr
    
    For Each flt In Me
        If Not acftDict.Exists(flt.TailNum) Then
            acftDict.Add flt.TailNum, True
            s = s & flt.ff_table_line & vbCrLf
        End If
    Next flt
    ff_table = s
    
ff_tableExit:
    Set acftDict = Nothing ' 显式释放对象
    Exit Function
    
ff_tableErr:
    HandleError "CFlights.ff_table()"
    Resume ff_tableExit
End Function

2. 迭代前快照集合元素 #

将集合元素提前复制到数组，避免迭代过程中集合状态变化引发的冲突：

Private Function ff_table() As String
    Dim fltArr() As Variant
    Dim i As Long
    Dim flt As CFlight
    Dim s As String
    Dim acftDict As Object
    
    Set acftDict = CreateObject("Scripting.Dictionary")
    On Error GoTo ff_tableErr
    
    ' 快照集合到数组，隔离迭代与原集合
    ReDim fltArr(1 To colFlights.Count)
    For i = 1 To colFlights.Count
        Set fltArr(i) = colFlights(i)
    Next i
    
    ' 遍历数组而非原集合
    For i = 1 To UBound(fltArr)
        Set flt = fltArr(i)
        If Not acftDict.Exists(flt.TailNum) Then
            acftDict.Add flt.TailNum, True
            s = s & flt.ff_table_line & vbCrLf
        End If
    Next i
    
    ff_table = s
    
ff_tableExit:
    Set acftDict = Nothing
    Set flt = Nothing
    Erase fltArr
    Exit Function
    
ff_tableErr:
    HandleError "CFlights.ff_table()"
    Resume ff_tableExit
End Function

3. 显式校验对象有效性 #

在ff_table_line中提前检查Me.Aircraft是否有效，避免隐式空引用崩溃：

Friend Function ff_table_line() As String
    Dim s As String
    On Error GoTo ff_table_lineErr
    
    ' 提前校验对象，避免空引用内存错误
    If Me.Aircraft Is Nothing Then
        ff_table_line = ""
        Resume ff_table_lineExit
    End If
    
    s = Me.TailNum & "," & Me.Aircraft.Model & "," & Me.Aircraft.ACType & ",,,," & Me.Aircraft.AppsCategory
    s = s & "," & Me.Aircraft.AppsClass & ",," & Me.Aircraft.Power & ",,,,"
    s = s & ",,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,"
    ff_table_line = s                       
    
ff_table_lineExit:
    Exit Function
    
ff_table_lineErr:
    HandleError "CFlight.ff_table_line()"
    Resume ff_table_lineExit
End Function

4. 优化内存占用（可选） #

如果最终要生成CSV文件，建议直接分批写入文件，而非拼接成超大字符串：

' 示例：直接写入文件替代字符串拼接
Private Sub ff_table_to_file(filePath As String)
    Dim flt As CFlight
    Dim acftDict As Object
    Dim ff As Integer
    
    ff = FreeFile()
    Open filePath For Output As #ff
    
    Set acftDict = CreateObject("Scripting.Dictionary")
    On Error GoTo ff_tableErr
    
    For Each flt In Me
        If Not acftDict.Exists(flt.TailNum) Then
            acftDict.Add flt.TailNum, True
            Print #ff, flt.ff_table_line
        End If
    Next flt
    
ff_tableExit:
    Close #ff
    Set acftDict = Nothing
    Exit Sub
    
ff_tableErr:
    HandleError "CFlights.ff_table_to_file()"
    Resume ff_tableExit
End Sub

临时排查验证（可选） #

若怀疑是消息队列阻塞导致崩溃，可在循环中临时添加DoEvents测试（不推荐长期使用，会降低运行效率）：

For Each flt In Me
    DoEvents ' 临时验证用，若崩溃消失则说明是消息阻塞问题
    ' ... 原有逻辑
Next flt

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