My VBA macro slows down dramatically with each use

0 votes

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.

Jan 21 in Others by Kithuzzz
• 27,740 points
33 views

1 answer to this question.

0 votes

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
answered Jan 21 by narikkadan
• 51,240 points

Related Questions In Others

0 votes
1 answer
0 votes
1 answer

Can I use multiple domain names for my website?

Well, if you are hosting a website, ...READ MORE

answered Oct 28, 2019 in Others by Barbara
254 views
0 votes
1 answer

Language independent way to get "My Documents" folder in VBA Excel 2003

 Hello :)  This code may help you in your ...READ MORE

answered Feb 16, 2022 in Others by Edureka
• 13,640 points
146 views
0 votes
1 answer

Wordpress Critical Error Due to Plugin Conflict with my Functions.php

modify your code like this and will ...READ MORE

answered Feb 24, 2022 in Others by narikkadan
• 51,240 points
340 views
0 votes
1 answer

Retrieve epay.info Balance with VBA and Excel

This code should log you in, provided ...READ MORE

answered Sep 5, 2018 in Blockchain by digger
• 26,740 points
522 views
0 votes
1 answer

How to load file to Excel Power query from SFTP site

Currently, I don't think there is a ...READ MORE

answered Dec 3, 2018 in Power BI by Upasana
• 8,620 points
2,382 views
0 votes
1 answer

Using VBA Excel to create a gramatically correct list

The Excel AND function is a logical ...READ MORE

answered Feb 9, 2022 in Others by gaurav
• 22,940 points
110 views
0 votes
2 answers

How to copy a formula horizontally within a table using Excel VBA?

Hi so basically, create an adjacent column ...READ MORE

answered Feb 16, 2022 in Others by Edureka
• 13,640 points
274 views
0 votes
1 answer

How To Use VBA To Share Excel File With Fellow Office User?

PowerApps were referenced; if you have a ...READ MORE

answered Oct 28, 2022 in Others by narikkadan
• 51,240 points
131 views
0 votes
1 answer

How do I use the Indirect Function in Excel VBA to incorporate the equations in a VBA Macro Function

Try this: Sub Test() Dim str As String: str ...READ MORE

answered Jan 19 in Others by narikkadan
• 51,240 points
51 views
webinar REGISTER FOR FREE WEBINAR X
REGISTER NOW
webinar_success Thank you for registering Join Edureka Meetup community for 100+ Free Webinars each month JOIN MEETUP GROUP