我的 VBA 宏在每次使用时都会显着变慢

Question

VBA新手在这里。

我有一个 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

我试过一段一段地删除代码的各个部分，但在连续运行后它似乎总是变慢。

Answer 1

因此，您有一个作为字符串的函数 ExportRange，但在函数中使用函数 ExportRange 变量时将其作为子例程调用……其值似乎/可能在每次运行时变得越来越大。我会尝试不是将函数用作自身的局部变量，请改用 Dim String。如果你需要一个全局变量，那么在函数外声明它。 是这样的：

Dim MyExportRange As String

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

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

  MyExportRange = ""

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

'Trim extra delimiter
MyExportRange = Left(MyExportRange, Len(MyExportRange) - 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, MyExportRange
Close #1
End Sub