I have simple macro to insert text to end of all text files in the folder that user chooses. It works for my data, but it takes 30 seconds for 40 files and CPU usage goes to 90%. Is this normal? Is there simple fix to macro to make this less CPU intensive?
Code:
Sub Batch_Insert_Text_End_of_File()
Application.ScreenUpdating = False
Dim strInFold As String, strOutFold As String, strFile As String, strOutFile As String, DocSrc As Document
Dim i As Long
'Call the GetFolder Function to determine the folder to process
strInFold = GetFolder
If strInFold = "" Then Exit Sub
strFile = Dir(strInFold & "\*.txt", vbNormal)
'Check for documents in the folder - exit if none found
If strFile <> "" Then strOutFold = strInFold & "\Output\"
'Test for an existing outpfolder & create one if it doesn't already exist
If Dir(strOutFold, vbDirectory) = "" Then MkDir strOutFold
strFile = Dir(strInFold & "\*.txt", vbNormal)
'Process all documents in the chosen folder
i = 1
While strFile <> ""
Set DocSrc = Documents.Open(FileName:=strInFold & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With DocSrc
Dim oRng As Range
Set oRng = DocSrc.Range 'oRng set to entire document
wrd = " 45 CALCULATE, 'BLIN-ARRAY-SIZE' = XXX $" & Chr(10) & _
" 50 END, 'INIT_TABLE_" & i & "' $"
oRng.InsertParagraphAfter
oRng.InsertAfter wrd
strOutFile = strOutFold & Split(.Name, ".")(0)
'Save and close the document
.SaveAs FileName:=strOutFile, FileFormat:=wdFormatText
.Close
End With
i = i + 1 'counter for index
strFile = Dir()
Wend
Set Rng = Nothing: Set DocSrc = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder(Optional Title As String, Optional RootFolder As Variant) As String
On Error Resume Next
GetFolder = CreateObject("Shell.Application").BrowseForFolder(0, Title, 0, RootFolder).Items.Item.Path
End Function