My VBA macro slows down dramatically with each use - excel

Question

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.

Answer 1

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

Answer 2

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