我的 VBA 宏在每次使用時都會顯着變慢

Question

VBA 新手在這里。

我有一個 VBA 宏，旨在在命名范圍內創建 data.table，將 data.table 粘貼為值，然后將 data.table 導出到 a.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

因此，您有一個 function ExportRange 作為字符串，但在使用 function 中的 function ExportRange 變量時將其稱為子例程...每次運行時其值似乎/可能變得越來越大。 我會嘗試不使用 function 作為其自身的局部變量，而是使用 Dim String。 如果你需要一個全局變量，那么在 function 之外聲明它。像這樣：

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

Answer 2

在一個范圍內逐個單元格循環可能會很慢，因此您可以嘗試將整個范圍讀入一個數組，然后從中寫入文件：

Sub tester()
    ExportRange ActiveSheet.Range("A1").CurrentRegion, "C:\Temp\Test56.txt", "," '
End Sub


Sub ExportRange(WhatRange As Range, Where As String, Delimiter As String)
    Dim arr, r As Long, c As Long, sep As String, s As String, ff
      
    If Len(Dir(Where)) > 0 Then Kill Where 'kill file if already exists
    ff = FreeFile
    Open Where For Output As #ff 'not appending...
    If WhatRange.Cells.Count > 1 Then
        arr = WhatRange.Value
        For r = 1 To UBound(arr, 1)
            s = ""
            sep = ""
            For c = 1 To UBound(arr, 2)
                s = s & sep & arr(r, c)
                sep = Delimiter
            Next c
            Print #ff, s
        Next r
    Else
        Print #ff, WhatRange.Value 'only one cell
    End If
    Close #ff
End Sub