My VBA macro slows down dramatically with each use-CodePudding

VBA newbie here.

I have a VBA macro which is designed to create a data table on a named range, paste the data table as values and then export the data table to a .txt file. The problem I have is that each time I run the macro it takes significantly longer to run than the previous time. If I restart Excel, however, the run time "resets" and becomes low again. Once or twice I have even received an error message that Excel has run out of resources. Any help would be greatly appreciated!

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.

CodePudding user response：

So, you have a function ExportRange as a string but call it as a subroutine while using the function ExportRange variable in the function...whose value seems to/could get larger and larger each time it's run. I would try not using the function as a local variable for itself, use a Dim String instead. If you need a global variable for it, then declare it outside the function. Something 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

CodePudding user response：

Looping cell-by-cell through a range can be slow, so you could try reading the whole range into an array and then writing the file from that:

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