VBA宏每次运行速度大幅变慢，重启Excel后恢复

我是VBA新手，写了一个宏用来在命名区域创建数据表格，粘贴为值后导出成.txt文件。现在遇到的问题是每次运行宏，耗时都会比上一次明显变长；但重启Excel后，运行时间又会回到初始的较短状态，甚至还出现过「Excel资源不足」的错误。我试过逐段移除代码，但连续运行后还是会变慢。以下是我的宏代码：

Sub PR_Calculate()
'
' Total Macro
'
    Application.ScreenUpdating = False
    
    Range("Output").Clear
    
    Range("CurrentOutput").Table ColumnInput:=Range("CurrentOutput").Cells(1, 1) 'apply data table to required range
      
    Range("Output").Font.Size = 8
    Range("Output").Font.Name = "Segoe UI"
    
    Application.Calculation = xlCalculationAutomatic
    Application.Calculation = xlCalculationSemiautomatic
    
    Range("Output").Copy
    Range("Output").PasteSpecial xlPasteValues
    
    Application.CutCopyMode = False

    Dim outputPath1 As String
    Dim outputPath2 As String
    
    outputPath1 = ActiveWorkbook.Worksheets("Run Setup").Range("OutputPath") & Range("CurrentRunParameters").Cells(2, 1).Value & "." & Range("CurrentRunParameters").Cells(2, 2).Value & ".txt"
    outputPath2 = ActiveWorkbook.Worksheets("Run Setup").Range("OutputPath") & Range("CurrentRunParameters").Cells(2, 1).Value & "." & Range("CurrentRunParameters").Cells(2, 2).Value & ".Headings.txt"

    Call ExportRange(ActiveWorkbook.Worksheets("Policy Results").Range("FileSaveRange"), outputPath1, ",") 'call function to export results to .txt file
    Call ExportRange(ActiveWorkbook.Worksheets("Policy Results").Range("HeadingSaveRange"), outputPath2, ",") 'call function to export results to .txt file
    
End Sub

Function ExportRange(WhatRange As Range, _
         Where As String, Delimiter As String) As String

  Dim HoldRow As Long    'test for new row variable
  HoldRow = WhatRange.Row
    
  Dim c As Range

  'loop through range variable
  For Each c In WhatRange
    If HoldRow <> c.Row Then
      'add linebreak and remove extra delimeter
      ExportRange = Left(ExportRange, Len(ExportRange) - 1) _
                          & vbCrLf & c.Text & Delimiter
        HoldRow = c.Row
    Else
        ExportRange = ExportRange & c.Text & Delimiter
    End If
Next c

'Trim extra delimiter
ExportRange = Left(ExportRange, Len(ExportRange) - 1)

'Kill the file if it already exists
If Len(Dir(Where)) > 0 Then
    Kill Where
End If

Open Where For Append As #1    'write the new file
Print #1, ExportRange
Close #1
End Function

你的代码存在内存泄漏和不必要的资源占用问题，导致每次运行后Excel的内存占用持续累积，最终变慢甚至报错。以下是针对性的优化：

1. 修复ExportRange的内存累积问题 #

原函数把整个范围内容拼接成超大字符串返回，这个字符串会长期占用内存；同时硬编码文件号#1可能导致文件句柄泄漏。改成逐行写入的子过程：

Sub ExportRange(WhatRange As Range, Where As String, Delimiter As String)
    Dim HoldRow As Long
    Dim c As Range
    Dim lineText As String
    Dim fileNum As Integer
    
    ' 删除旧文件
    If Len(Dir(Where)) > 0 Then Kill Where
    
    ' 获取可用文件号，避免句柄冲突
    fileNum = FreeFile
    
    Open Where For Output As #fileNum
        HoldRow = WhatRange.Row
        lineText = ""
        For Each c In WhatRange
            If HoldRow <> c.Row Then
                ' 写入当前行并移除末尾分隔符
                Print #fileNum, Left(lineText, Len(lineText) - 1)
                lineText = c.Text & Delimiter
                HoldRow = c.Row
            Else
                lineText = lineText & c.Text & Delimiter
            End If
        Next c
        ' 写入最后一行
        Print #fileNum, Left(lineText, Len(lineText) - 1)
    Close #fileNum
End Sub

• 用Sub替代Function，避免返回大字符串占用内存
• 逐行写入文件，大幅降低内存开销
• 使用FreeFile获取安全的文件号，防止句柄泄漏

2. 清理旧数据表格残留 #

每次运行Table方法时，旧的数据表格对象可能没被正确清理，导致Excel堆积无用对象。在创建新表格前添加清理逻辑：

' 清理当前区域已存在的数据表格
Dim tbl As ListObject
On Error Resume Next
Set tbl = ActiveSheet.ListObjects("CurrentOutput") ' 替换为你的表格名称（如果有）
On Error GoTo 0
If Not tbl Is Nothing Then tbl.Delete

3. 优化Excel应用级资源设置 #

原代码的计算模式切换无意义，还会触发额外计算。调整为保存原始设置并禁用不必要功能：

Sub PR_Calculate()
    ' 保存Excel原始设置
    Dim origScreenUpdating As Boolean
    Dim origCalculation As XlCalculation
    Dim origEnableEvents As Boolean
    
    origScreenUpdating = Application.ScreenUpdating
    origCalculation = Application.Calculation
    origEnableEvents = Application.EnableEvents
    
    ' 禁用不必要功能提升速度
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    ' 确保出错时能恢复设置
    On Error GoTo Cleanup
    
    Dim policySheet As Worksheet
    Set policySheet = ActiveWorkbook.Worksheets("Policy Results")
    Dim runSheet As Worksheet
    Set runSheet = ActiveWorkbook.Worksheets("Run Setup")
    Dim paramRange As Range
    Set paramRange = policySheet.Range("CurrentRunParameters")
    
    policySheet.Range("Output").Clear
    
    ' 清理旧数据表格
    Dim tbl As ListObject
    On Error Resume Next
    Set tbl = policySheet.ListObjects("CurrentOutput")
    On Error GoTo 0
    If Not tbl Is Nothing Then tbl.Delete
    
    policySheet.Range("CurrentOutput").Table ColumnInput:=policySheet.Range("CurrentOutput").Cells(1, 1)
      
    ' 用With减少重复引用
    With policySheet.Range("Output")
        .Font.Size = 8
        .Font.Name = "Segoe UI"
        .Copy
        .PasteSpecial xlPasteValues
    End With
    
    Application.CutCopyMode = False

    Dim outputPath1 As String
    Dim outputPath2 As String
    
    outputPath1 = runSheet.Range("OutputPath") & paramRange.Cells(2, 1).Value & "." & paramRange.Cells(2, 2).Value & ".txt"
    outputPath2 = runSheet.Range("OutputPath") & paramRange.Cells(2, 1).Value & "." & paramRange.Cells(2, 2).Value & ".Headings.txt"

    ExportRange policySheet.Range("FileSaveRange"), outputPath1, ","
    ExportRange policySheet.Range("HeadingSaveRange"), outputPath2, ","
    
Cleanup:
    ' 恢复Excel原始设置
    Application.ScreenUpdating = origScreenUpdating
    Application.Calculation = origCalculation
    Application.EnableEvents = origEnableEvents
    Application.CutCopyMode = False
    
    ' 错误提示
    If Err.Number <> 0 Then
        MsgBox "运行出错: " & Err.Description, vbExclamation
        Err.Clear
    End If
End Sub

• 保存并恢复原始设置，避免影响后续操作
• 禁用EnableEvents，防止触发不必要的工作表事件
• 明确指定工作表对象，避免隐式引用导致的资源浪费

4. 避免隐式范围引用 #

原代码中Range("xxx")未指定工作表，Excel会默认查找活动表，不仅容易出错还会增加资源开销。所有范围引用都要明确对应工作表（如上面优化后的代码所示）。

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