CODEWITHSUNDEEP
performancevbams-word
MW600
MW600

Reputation: 43

VBA Macro gets slower with every execution

I have a macro that reads a .txt file line by line. I check every line if it's equal to some code for a new page, say it's "NEXT" - if yes, then a page break is inserted. After certain amount of "NEXT" occurences the whole document gets exported to pdf. Then the content of .doc gets deleted and I continue reading & exporting the txt file until EOF.

Problem: macro gets slower with every execution.

My test file has 27300 lines / 791 kB (real files are somewhere between 10 and 100MB). Before I start the macro, the WINWORD process takes 40K of memory. The memory usage gets bigger after every execution of the macro.

        Time    Max.MemoryUsage  MemoryUsageAfterwards
Run1    11.9s   70K              64K
Run2    19.7s   90K              84K
Run3    22.3s   99K              92K

I know a partial solution is to close and reopen the .doc file manually and run the macro with next .txt file as input. However, it takes long time to even close the Word after one run of macro, although there is no content in the file that I can see.

What I'm asking is if there is another way to solve this, what I believe is to be a memory clearing issue?

My code:

When the document is opened: 

Private Sub Document_Open()
    ReadAndSplit
End Sub

Global variables and declarations:

Option Explicit
'---------------------------------------------------------------------------
'                                       GLOBAL VARIABLES
'---------------------------------------------------------------------------
Public numOfBreaks  As Integer          ' number of page breaks made
Public numOfPdfs    As Integer          ' number of currently printed pdf
Public filePrefix   As String           ' name prefix for .pdf files
Public sFileName    As String           ' name of Input File
Public breakAfter   As Integer          ' print after this number of NEXT
Public cancelActive As Boolean          ' cancel Button pressed? (for exit)

Main macro:

Sub ReadAndSplit()
'---------------------------------------------------------------------------
'                                       VARIABLES
'---------------------------------------------------------------------------
Dim sLine           As String           ' line from text file
Dim numOfLines      As Long             ' number of lines read from .txt input
Dim execStart       As Single           ' starting time of script execution
Dim nextPage        As Boolean          ' indicates if new document beginns

'---------------------------------------------------------------------------
'                                       INITIAL PROCESSING
'---------------------------------------------------------------------------    
Application.Visible = False              
Application.ScreenUpdating = False       
Selection.WholeStory                    ' clear the document
Selection.Delete
UserForm1.Show                          ' show user dialog
If cancelActive Then                    ' Cancel button handling
    Application.Visible = True
    Exit Sub
End If

With ActiveDocument.PageSetup           ' set page margins & orientation
    .TopMargin = 0.1
    .BottomMargin = 0.1
    .LeftMargin = 0.1
    .RightMargin = 0.1
End With
'---------------------------------------------------------------------------
'                                       MAIN PROCESSING
'---------------------------------------------------------------------------
numOfBreaks = 0                         ' GLOBALS
numOfPdfs = 1
numOfLines = 0                          ' LOCALS
nextPage = True
execStart = Timer

Open sFileName For Input As #1

Do While Not EOF(1)

    If nextPage Then                                    ' write 2 empty lines
        Selection.TypeText (vbNewLine & vbNewLine)
        nextPage = False
    End If

    Line Input #1, sLine                                ' read 1 line from input
    numOfLines = numOfLines + 1                         ' count lines

    If sLine <> "NEXT" Then                             ' test for NEXT
        Selection.TypeText (sLine) & vbNewLine          ' write line from input .txt
    Else
        Selection.InsertBreak Type:=wdPageBreak         ' NEXT -> new page
        numOfBreaks = numOfBreaks + 1                   ' count new receipts

        If numOfBreaks = breakAfter Then                ' compare with PARAM
            PrintAsPDF                                  ' export to pdf
            numOfBreaks = 0
        End If

        nextPage = True                                 ' switch new page on
    End If
Loop

If numOfBreaks <> 0 Then                                ' print out the last part
    PrintAsPDF
End If

Close #1

Debug.Print vbNewLine & "-----EXECUTION-----"
Debug.Print Now
Debug.Print "Lines: " & numOfLines
Debug.Print "Time: " & (Timer - execStart)
Debug.Print "-------------------" & vbNewLine

Selection.WholeStory                                    ' clear the word document
Selection.Delete

Application.Visible = True

End Sub

Macro used for printing PDF:

Sub PrintAsPDF()

Dim newPdfFileName  As String           ' path + name for current .pdf file

newPdfFileName = ActiveDocument.Path & "\" & filePrefix & "-" & numOfPdfs & ".pdf"

Selection.WholeStory                    ' set font
With Selection.Font
    .Name = "Courier New"
    .Size = 10.5
End With

ActiveDocument.SaveAs2 newPdfFileName, 17

numOfPdfs = numOfPdfs + 1

Selection.WholeStory
Selection.Delete

End Sub

UserForm code:

'---------------------------------------------------------------------------
'                                       OK BUTTON
'---------------------------------------------------------------------------
Private Sub OKButton_Click()

Dim inputFileOk     As Boolean  ' input file path
Dim inputSplitOk    As Boolean  ' split
Dim prefixOk        As Boolean  ' prefix

If FileTxtBox.Text = vbNullString Then          ' validate file path
    inputFileOk = False
    MsgBox ("File path missing!")
Else
    inputFileOk = True
End If

If IsNumeric(SplitTxtBox.Text) Then             ' validate breakAfter
    breakAfter = SplitTxtBox.Text
    inputSplitOk = True
Else
    MsgBox ("Non-numeric value for SPLIT!")
End If

If PrefixTxtBox <> vbNullString Then            ' validate prefix
    filePrefix = PrefixTxtBox.Text
    prefixOk = True
Else
    MsgBox ("Missing prefix!")
End If

                                                ' check if all inputs are ok
If inputFileOk And inputSplitOk And prefixOk Then
    cancelActive = False
    Unload Me
End If

End Sub
'---------------------------------------------------------------------------
'                                       CANCEL BUTTON
'---------------------------------------------------------------------------
Private Sub CancelButton_Click()
cancelActive = True             ' for script termination
Unload Me
End Sub
'---------------------------------------------------------------------------
'                                       FILE BUTTON
'---------------------------------------------------------------------------
Private Sub FileButton_Click()    
Dim i           As Integer      ' file selection index

' show file chooser dialog and assign selected file to sFileName
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
i = Application.FileDialog(msoFileDialogOpen).Show

If i <> 0 Then
    sFileName = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
    FileTxtBox.Text = sFileName
End If

End Sub

Upvotes: 1

Views: 1302

Answers (1)

Cindy Meister
Cindy Meister

Reputation: 25693

Word stores a lot of information in "temp" files in order to track "unlimited" Undo. If you perform a lot of actions without saving the file or clearing the Undo buffer, this slows Word down. I recommend, therefore:

  1. Clear the Undo buffer (ActiveDocument.UndoClear)
  2. Save the (empty) document periodically

in order to free resources.

Upvotes: 3

Related Questions