Macro slows down over time

[prefect]

Hello,

Inexperienced VBA user here (MS office 2010), having problems with a macro slowing down over time.
The macro is for extracting highlighted words from Word files onto a separate text file.
In other words, the Macro lets user select a folder with Word files, and then goes through all files in that folder and extracts every highlighted word text onto a separate text file.

Initially the macro runs quickly, but it slows down considerably over time (in terms of how quickly it reads Word files in the folder) to the point where it is 3x slower than it was at the beginning, and still keeps getting slower.
I am working with large numbers of Word docs so it is a big problem. I have made some additions to the macro but without results.
Here is the code:



Global ExtractFile As String

Sub HighlightExtractAllArticlesNoKeywords()
Dim intResult As Integer
Dim strPath As String
Dim arrFiles() As String
Dim i As Integer
Dim k As Integer
Dim sFileName As String
Dim iFileNum As Integer
Dim sBuf As String

MsgBox "Click OK and select the folder containing the documents"

intResult = Application.FileDialog(msoFileDialogFolderPicker).Show
'checks if user has canceled the dialog
If intResult <> 0 Then
'dispaly message box
strPath = Application.FileDialog( _
msoFileDialogFolderPicker).SelectedItems(1)
arrFiles() = GetAllFilePaths(strPath)

MsgBox "Click OK and select the text file to which dates & tickers should be extracted. Preferably a *.txt file"
Application.FileDialog(msoFileDialogFilePicker).Show
ExtractFile = Application.FileDialog( _
msoFileDialogFilePicker).SelectedItems(1)

For i = LBound(arrFiles) To UBound(arrFiles)
Call ExtractKeywords(arrFiles(i))
Next i
End If
End Sub


Private Sub ExtractKeywords(ByVal strPath As String)

Application.ScreenUpdating = False
Dim objDocument As Document
Set objDocument = Documents.Open(strPath)
objDocument.Activate
Application.ScreenUpdating = False
Dim rng As Range
Set oRng = objDocument.Range
Selection.WholeStory
Selection.Fields.Unlink 'this removes hyperlinks
Dim oNewDoc As Document
Set oNewDoc = Documents.Open(FileName:=ExtractFile, AddToRecentFiles:=False) 'The name and path of the document to record the data, document must exist
With oRng.Find
.Highlight = True
Do While .Execute
If oRng.HighlightColorIndex = wdYellow Then
oNewDoc.Range.InsertAfter oRng.Text & vbCr
oRng.Collapse 0
End If
oNewDoc.UndoClear
Loop
oNewDoc.Save
End With
Set oNewDoc = Nothing
Set oRng = Nothing
Set objDocument = Nothing
objDocument.Close (True)

End Sub

Private Function GetAllFilePaths(ByVal strPath As String) _
As String()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim arrOutput() As String
ReDim arrOutput(1 To 1)
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(strPath)
i = 1
'loops through each file in the directory and
'prints their names and path
For Each objFile In objFolder.Files
ReDim Preserve arrOutput(1 To i)
'print file path
arrOutput(i) = objFile.Path
i = i + 1
Next objFile
GetAllFilePaths = arrOutput
Set objFSO = Nothing
Set objFolder = Nothing
End Function



I want the macro to always run as fast as it does at the beginning. Is that possible?

Thanks,
Prefect

[gmaxey]

It may not be possible. MS has made some changes to the in Word 2010 and later that apparently cause this behavior see:
http://www.msofficeforums.com/word-vba/29645-vba-shapes-very-slow.html

[gmayor]

I have not tested the code, but there are some variable name anomalies and processes that can slow progress. The following may help


Option Explicit

Sub HighlightExtractAllArticlesNoKeywords()
Dim oNewDoc As Document
Dim ExtractFile As String
Dim intResult As Integer
Dim strPath As String
Dim arrFiles() As String
Dim i As Integer
Dim k As Integer
Dim sFileName As String
Dim iFileNum As Integer
Dim sBuf As String

MsgBox "Click OK and select the folder containing the documents"

intResult = Application.FileDialog(msoFileDialogFolderPicker).Show
'checks if user has canceled the dialog
If intResult <> 0 Then
'display message box
strPath = Application.FileDialog( _
msoFileDialogFolderPicker).SelectedItems(1)
arrFiles() = GetAllFilePaths(strPath)

MsgBox "Click OK and select the text file to which dates & tickers should be extracted. Preferably a *.txt file"
Application.FileDialog(msoFileDialogFilePicker).Show

ExtractFile = Application.FileDialog( _
msoFileDialogFilePicker).SelectedItems(1)
Set oNewDoc = Documents.Open(Filename:=ExtractFile, AddToRecentFiles:=False) 'The name and path of the document to record the data, document must exist
Application.ScreenUpdating = False

For i = LBound(arrFiles) To UBound(arrFiles)
Call ExtractKeywords(arrFiles(i), oNewDoc)
DoEvents
Next i
End If
Application.ScreenUpdating = True
lbl_Exit:
Set oNewDoc = Nothing
Exit Sub
End Sub

Private Sub ExtractKeywords(ByVal strPath As String, oNewDoc As Document)
Dim oRng As Range
Dim objDocument As Document

Set objDocument = Documents.Open(strPath)
Set oRng = objDocument.Range
oRng.Fields.Unlink 'this removes hyperlinks
With oRng.Find
.Highlight = True
Do While .Execute
If oRng.HighlightColorIndex = wdYellow Then
oNewDoc.Range.InsertAfter oRng.Text & vbCr
oRng.Collapse 0
End If
oNewDoc.UndoClear
Loop
oNewDoc.Save
End With
objDocument.Close wdDoNotSaveChanges
lbl_Exit:
Set oRng = Nothing
Set objDocument = Nothing
Exit Sub
End Sub

Private Function GetAllFilePaths(ByVal strPath As String) _
As String()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim arrOutput() As String
ReDim arrOutput(1 To 1)
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(strPath)
i = 1
'loops through each file in the directory and
'prints their names and path
For Each objFile In objFolder.Files
ReDim Preserve arrOutput(1 To i)
'print file path
arrOutput(i) = objFile.Path
i = i + 1
Next objFile
GetAllFilePaths = arrOutput
lbl_Exit:
Set objFSO = Nothing
Set objFolder = Nothing
Exit Function
End Function

[prefect]

Thanks gmayor, it worked! Now the macro runs at constant speed and does not slow down. I am looking through your code to learn what my mistake was that led to slow performance, as it is not clear to me yet.

In addition, I tried to modify another macro similarly. However, the problem with another macro is that it runs out of memory and corrupts files. The macro is supposed to go through all files in a selected folder and highlight certain text items.

Now it runs at constant speed, however after a certain file number it starts to corrupt the subsequent files despite still processing them. Application.ScreenUpdating is set to False and it appears that the macro processes all files normally, but when it is finished, all files after a certain file number are corrupted and cannot be opened. Also, if I try to go to the macro editor and copy something when the macro is finished, it can't copy and says "out of memory", so I assume it is a memory issue. Here is the code:


Option Explicit

Sub ExtractAllDatesTickersFinal()
Dim oNewDoc As Document
Dim ExtractFile As String
Dim intResult As Integer
Dim strPath As String
Dim arrFiles() As String
Dim i As Integer
Dim k As Integer
Dim sFileName As String
Dim iFileNum As Integer
Dim sBuf As String

MsgBox "Click OK and select the folder containing the documents"

intResult = Application.FileDialog(msoFileDialogFolderPicker).Show
'checks if user has canceled the dialog
If intResult <> 0 Then
'display message box
strPath = Application.FileDialog( _
msoFileDialogFolderPicker).SelectedItems(1)
arrFiles() = GetAllFilePaths(strPath)

Application.ScreenUpdating = False

For i = LBound(arrFiles) To UBound(arrFiles)
Call HighlightKeywordsDatesTickers(arrFiles(i))
DoEvents
Next i
End If
Application.ScreenUpdating = True
lbl_Exit:
Set oNewDoc = Nothing
Exit Sub
End Sub




Private Sub HighlightKeywordsDatesTickers(ByVal strPath As String)


Dim oRng As Range
Dim objDocument As Document
Dim StrFnd As String, i As Long,
Set objDocument = Documents.Open(strPath)
Set oRng = objDocument.Range
Dim WdNoColor As Long


oRng.HighlightColorIndex = WdNoColor
Options.DefaultHighlightColorIndex = wdYellow


StrFnd = "\(NYSE:*\),\(Nyse:*\),\(nyse:*\),\(NASDAQ:*\),\(Nasdaq:*\),\(nasdaq:*\)"
For i = 0 To UBound(Split(StrFnd, ","))
With oRng.Find
.ClearFormatting
.Text = Split(StrFnd, ",")(i)
.Replacement.ClearFormatting
.Replacement.Highlight = True
.Replacement.Text = "^&"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
Next

objDocument.UndoClear
objDocument.Close wdSaveChanges
lbl_Exit:
Set oRng = Nothing
Set objDocument = Nothing
Exit Sub
End Sub



Private Function GetAllFilePaths(ByVal strPath As String) _
As String()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim arrOutput() As String
ReDim arrOutput(1 To 1)
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(strPath)
i = 1
'loops through each file in the directory and
'prints their names and path
For Each objFile In objFolder.Files
ReDim Preserve arrOutput(1 To i)
'print file path
arrOutput(i) = objFile.Path
i = i + 1
Next objFile
GetAllFilePaths = arrOutput
lbl_Exit:
Set objFSO = Nothing
Set objFolder = Nothing
Exit Function
End Function




What could be causing the memory issue here? The speed of the macro is OK, but I don't want it to corrupt files due to presumably running out of memory.

Regards,
Prefect

[prefect]

PS it seems the macro in the previous reply (which highlights documents) also has the slowing down problem after all. The extracting macro you corrected works fine, do you see any changes that could be made to the highlighting macro to make it work at constant speed and not have the memory problem?

[gmayor]

You had a number of declared variables that were unused in the code, you had a a variable (wdNoColor) set that you used, the value of which was not defined (and in any case is unnecessary) and your loop wouldn't work the way you had orng set. Whether these anomalies are sufficient to cause the corruption I cannot say, but the following does work on my tests without corruption.
I don't know if you really intended to clear all the highlighting from the document, but I have left that option in, though commented outr It is not required to highlight your text strings

Option Explicit

Sub ExtractAllDatesTickersFinal()
Dim strPath As String
Dim strFile As String
Dim i As Integer
Dim sFileName As String
strPath = BrowseForFolder("Select the folder to process")
strFile = Dir$(strPath & "*.do?")
Application.ScreenUpdating = False
While strFile <> ""
HighlightKeywordsDatesTickers strPath & strFile
DoEvents
strFile = Dir$()
Wend
Application.ScreenUpdating = True
lbl_Exit:
Exit Sub
End Sub

Private Sub HighlightKeywordsDatesTickers(ByVal strPath As String)
Dim oRng As Range
Dim objDocument As Document
Dim i As Long
Const strFnd As String = "\(NYSE:*\),\(Nyse:*\),\(nyse:*\),\(NASDAQ:*\),\(Nasdaq:*\),\(nasdaq:*\)"
If Right(LCase(strPath), 4) = "docx" Then
Set objDocument = Documents.Open(Filename:=strPath, AddToRecentFiles:=False)
'objDocument.Range.HighlightColorIndex = wdNoHighlight 'Are you sure you want this?
For i = 0 To UBound(Split(strFnd, ","))
Set oRng = objDocument.Range 'set the range here, inside the loop.
With oRng.Find
Do While .Execute(FindText:=Split(strFnd, ",")(i), _
MatchWildcards:=True)
oRng.HighlightColorIndex = wdYellow
'oRng.Words(2).Case = wdUpperCase 'Puts the keywords in upper case.
oRng.Collapse 0
Loop
End With
DoEvents
Next i
objDocument.UndoClear
objDocument.Close wdSaveChanges
End If
lbl_Exit:
Set oRng = Nothing
Set objDocument = Nothing
Exit Sub
End Sub

Private Function BrowseForFolder(Optional strTitle As String) As String
'Graham Mayor
'strTitle is the title of the dialog box
Dim fDialog As FileDialog
On Error GoTo err_Handler
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.Title = strTitle
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then GoTo err_Handler:
BrowseForFolder = fDialog.SelectedItems.Item(1) & Chr(92)
End With
lbl_Exit:
Exit Function
err_Handler:
BrowseForFolder = vbNullString
Resume lbl_Exit
End Function

[prefect]

Sorry for the late reply. Thank you very much! I will take a look at the code, but yes it seems I did declare more variables in my code than necessary.

Thanks again,
Prefect

[prefect]

I have tried running the macro, there will be a pop-up window to select the folder to process, but nothing happens after that. Perhaps there is a problem with this part?:

While strFile <> ""
HighlightKeywordsDatesTickers strPath & strFile
Do Events
strFile = Dir$()
Wend

Regards,
Prefect

[prefect]

Double checked, it seems the problem was that my articles were in .rtf format, now the macro is running. I will see whether any files get corrupted after it finishes. Thanks!