运行Excel VBA宏提示计算公式资源不足，部分设备Excel直接崩溃

• 逐行循环操作单元格：8000行数据逐行读写单元格属于极低效率的操作，VBA每次和Excel工作表交互都会消耗大量资源，循环次数过多会直接导致资源耗尽。
• 未明确指定工作表对象：代码中所有未带工作表前缀的Range、Cells默认引用当前活动工作表，如果运行宏时活动工作表不是Sheet1或CALCULATION，会误读/误写超大范围的单元格，触发不必要的计算甚至内存溢出。
• 空行查找逻辑冗余：用While循环逐行判断目标行是否为空，数据量越大遍历消耗的资源越高。
• 语法错误导致范围引用异常：
  • Source.Cells("1,")是错误语法，Cells正确传参为行号、列号，错误写法会读取到非预期的单元格范围
  • Subtotal统计的范围Range("$E2:D" & ...)列号顺序颠倒，且未限定工作表，实际会引用到远超预期的行范围，导致计算资源耗尽
• 频繁切换自动筛选状态：5次切换筛选+调用Subtotal的逻辑完全没有必要，反复修改工作表筛选状态会大幅增加资源消耗。
• 清理过程范围引用错误：Clear过程中的Range(Cells(2, 11), Cells(Rows.Count, 1))未指定所属工作表，可能误删其他表数据或者操作整表超大范围。

1. 用批量赋值替代逐行循环：直接将源表整段数据一次性写入目标表，可减少99%的工作表交互次数
2. 所有单元格/范围引用前明确指定所属工作表，避免引用混乱
3. 用End(xlUp)直接获取目标表最后一行，替代逐行遍历的While循环
4. 用CountIf函数替代筛选+Subtotal的统计逻辑，无需修改工作表状态即可完成分类统计
5. 修正所有语法错误，限定所有计算范围的边界
6. 增加错误处理分支，确保运行出错时也能恢复Excel的屏幕更新、计算模式等系统配置
7. 避免宏名与Excel内置方法重名，将原Calculate宏重命名为CalcData

Sub CalcData()
    ' 声明变量
    Dim Source As Worksheet
    Dim Target As Worksheet
    Dim lastSourceRow As Long
    Dim lastTargetRow As Long
    Dim calcRange As Range
    Dim t As Date
    
    ' 初始化配置
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    On Error GoTo ErrHandler ' 错误捕获
    
    Set Source = ActiveWorkbook.Worksheets("Sheet1")
    Set Target = ActiveWorkbook.Worksheets("CALCULATION")
    t = Now()
    
    ' 校验源表数据
    If Source.Cells(1, 1) = Empty Then
        MsgBox "Please check if there is data in Sheet1"
        GoTo Finish
    End If
    
    ' 批量复制源表A:K列数据到目标表
    lastSourceRow = Source.UsedRange.Rows(Source.UsedRange.Rows.Count).Row
    lastTargetRow = Target.Cells(Target.Rows.Count, 6).End(xlUp).Row + 1 ' 从F列第一个空行开始写
    Source.Range("A1:K" & lastSourceRow).Copy Target.Range("A" & lastTargetRow)
    
    ' 统计分类数量
    lastTargetRow = Target.Cells(Target.Rows.Count, "A").End(xlUp).Row
    Set calcRange = Target.Range("J1:J" & lastTargetRow) ' 第10列为分类列
    
    Target.Range("M2") = Application.WorksheetFunction.CountIf(calcRange, "Domestic Shares")
    Target.Range("M3") = Application.WorksheetFunction.CountIf(calcRange, "Foreign Shares")
    Target.Range("M4") = Application.WorksheetFunction.CountIf(calcRange, "Bonds EUR In")
    Target.Range("M5") = Application.WorksheetFunction.CountIf(calcRange, "Bonds EUR Out")
    Target.Range("M6") = Application.WorksheetFunction.CountIf(calcRange, "Own Products AB")
    
    MsgBox "Elapsed Time in Hrs:Min:Sec :" & Format(Now() - t, "hh:mm:ss")
    
Finish:
    ' 恢复配置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Target.AutoFilterMode = False
    Application.EnableEvents = True
    Exit Sub
    
ErrHandler:
    MsgBox "运行出错：" & Err.Description
    Resume Finish
End Sub

Sub Clear()
    With Worksheets("CALCULATION")
        .Range("A2:K" & .Rows.Count).ClearContents
        .Range("M2:M6").ClearContents
    End With
End Sub

Sub Clear2()
    Worksheets("Sheet1").Cells.Clear
End Sub

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