My VBA macro slows down dramatically with each use

Question

My VBA macro creates a data table on a named range, copies the data table as values, then exports the data table to a text file. The issue I have is that the macro takes a lot longer to run than it did the last time I ran it. However, if I restart Excel, the run time "resets" and drops once more. I've even occasionally seen an error message saying that Excel has run out of resources.

Here is the macro:

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

I've tried removing sections of the code piece by piece but it always seems to slow down after consecutive runs.

narikkadan · Answer 1 · Jan 21, 2023

You have a function called ExportRange that is implemented as a string, but you call it from a subroutine while using the function ExportRange variable, whose value appears to/could increase over time. I would experiment with using a Dim String in place of the function as a local variable for itself. Declare the global variable outside the function if you need one. Possibly like this:

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