Large Scale Find Replace, Loop to all files in folder

[KippT]

Hello,

I am attempting to create VBA code for Word that uses an excel spread sheet as a find replace list and loops through all the files in a folder. I have found a code for the large scale find replace and code to loop through all the files in a folder. Separately both codes will work however when I combine the two VBA codes the loop only works on the open file and ends on the first loop back to the (Do While MyFile <> ""). I'm not sure where the error is but seems to be related to when I call the Excel library which causes the loop to fail. I am using an Excel macro enabled file and a .doc word document in Office 2013. I would greatly appreciate any help resolving the code. I've included my attempt below:




Public Sub BatchReplaceAll()

Dim FirstLoop As Boolean
Dim MyFile As String
Dim PathToUse As String
Dim myDoc As Document
Dim Response As Long

PathToUse = "C:\Users\Kipp\Desktop\VBA test\"
'Error handler to handle error generated whenever
'the FindReplace dialog is closed
On Error Resume Next
'Close all open documents before beginning
'Documents.Close SaveChanges:=wdPromptToSaveChanges

ActiveDocument.Close SaveChanges:=wdPromptToSaveChanges
'Boolean expression to test whether first loop
'This is used so that the FindReplace dialog will
'only be displayed for the first document

'Set the directory and type of file to batch process
MyFile = Dir(PathToUse & "*.doc")


Do While MyFile <> ""
While stepping through and looping back to the Do While the Program Exits


'Open document
Set myDoc = Documents.Open(PathToUse & MyFile)
If FirstLoop Then
'Display dialog on first loop only
WorkingBulkFindReplace
FirstLoop = False

Else

WorkingBulkFindReplace
End If
'Close the modified document after saving changes
myDoc.Save
myDoc.Close SaveChanges:=wdSaveChanges

'Next file in folder
MyFile = Dir()
Loop
End Sub
........................................................................... ......................................................





Sub WorkingBulkFindReplace()
Application.ScreenUpdating = True

'Declare Variables
Dim xlApp As Object
Dim xlWkBk As Object
Dim StrWkBkNm As String
Dim StrWkSht As String
Dim bStrt As Boolean
Dim iDataRow As Long
Dim bFound As Boolean
Dim xlFList As String
Dim xlRList As String
Dim i As Long, Rslt

'Find Work Book File
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Desktop\VBA test" & "\Book1.xlsm"
StrWkSht = "Sheet1"
' Check to see if Excel is already running
If Dir(StrWkBkNm) = "" Then
MsgBox "Cannot find the designated workbook:" & StrWkBkNm, vbExclamation
Exit Sub

End If

' If Excel is not already running then Start
On Error Resume Next
bStrt = False
Set xlApp = GetObject(, "Excel.Application")
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excell.Application")
If xlApp Is Nothing Then
MsgBox "Cant start Excel.", vbExclamation
Exit Sub
End If
bStrt = True
End If
'Hide Open Work Application
On Error GoTo 0
bFound = False
With xlApp
If bStrt = True Then .Visible = False
For Each xlWkBk In .Workbooks
If xlWkBk.FullName = StrWkBkNm Then
Set xlWkBk = xlWkBk
bFound = True
Exit For
End If
'Check if another user has the work book open.
Next
If bFound = False Then
If IsFileLocked(StrWkBkNm) = True Then
MsgBox "The Excel workbook is in use." & vbCr & "Please try again later.", vbExclamation, "File in use"
If bStrt = True Then .Quit
Exit Sub
End If
Set xlWkBk = .Workbooks.Open(filename:=StrWkBkNm)
If xlWkBk Is Nothing Then
MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
If bStrt = True Then .Quit
Exit Sub
End If
End If


'Process the workbook
With xlWkBk.Worksheets(StrWkSht)
iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
For i = 1 To iDataRow
If Trim(.Range("A" & i)) <> vbNullString Then
xlFList = xlFList & "|" & Trim(.Range("A" & i))
xlRList = xlRList & "|" & Trim(.Range("B" & i))
End If


Next

End With
If bFound = False Then xlWkBk.Close False
If bStrt = True Then .Quit
End With

Set xlWkBk = Nothing: Set xlApp = Nothing
' Process each word from the F/R List
For i = 1 To UBound(Split(xlFList, "|"))
With ActiveDocument.Range

With .Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWholeWord = True
.MatchCase = True
.Wrap = wdFindStop
.Text = Split(xlFList, "|")(i)
.Replacement.Text = Split(xlRList, "|")(i)
.Execute Replace:=wdReplaceAll

End With
End With
Next
Application.ScreenUpdating = True
End Sub


........................................................................... ............................
Function IsFileLocked(strFileName As String) As Boolean
On Error Resume Next
Open strFileName For Binary Access Read Write Lock Read Write As #1
Close #1
IsFileLocked = Err.Number
Err.Clear
End Function

[macropod]

Try:

Sub BulkFindReplace ()
Application.ScreenUpdating = True
Dim strFolder As String, strFile As String, wdDoc As Document, i As Long
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim bStrt As Boolean, iDataRow As Long, bFound As Boolean, xlFList, xlRList
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\BulkFindReplace.xls"
StrWkSht = "Sheet1"
If Dir(StrWkBkNm) = "" Then
MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
Exit Sub
End If
'Get the folder to process
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
' Test whether Excel is already running.
On Error Resume Next
bStrt = False ' Flag to record if we start Excel, so we can close it later.
Set xlApp = GetObject(, "Excel.Application")
'Start Excel if it isn't running
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
MsgBox "Can't start Excel.", vbExclamation
Exit Sub
End If
' Record that we've started Excel.
bStrt = True
End If
On Error GoTo 0
'Check if the workbook is open.
bFound = False
With xlApp
'Hide our Excel session
If bStrt = True Then .Visible = False
For Each xlWkBk In .Workbooks
If xlWkBk.FullName = StrWkBkNm Then ' It's open
Set xlWkBk = xlWkBk
bFound = True
Exit For
End If
Next
' If not open by the current user.
If bFound = False Then
' Check if another user has it open.
If IsFileLocked(StrWkBkNm) = True Then
' Report and exit if true
MsgBox "The Excel workbook is in use." & vbCr & "Please try again later.", vbExclamation, "File in use"
If bStrt = True Then .Quit
Exit Sub
End If
' The file is available, so open it.
Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm)
If xlWkBk Is Nothing Then
MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
If bStrt = True Then .Quit
Exit Sub
End If
End If
' Process the workbook.
With xlWkBk.Worksheets(StrWkSht)
' Find the last-used row in column A.
' Add 1 to get the next row for data-entry.
iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
' Output the captured data.
For i = 1 To iDataRow
' Skip over empty fields to preserve the underlying cell contents.
If Trim(.Range("A" & i)) <> vbNullString Then
xlFList = xlFList & "|" & Trim(.Range("A" & i))
xlRList = xlRList & "|" & Trim(.Range("B" & i))
End If
Next
End With
If bFound = False Then xlWkBk.Close False
If bStrt = True Then .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
'Process each document in the folder
While strFile <> ""
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
'Process each word from the F/R List
For i = 1 To UBound(Split(xlFList, "|"))
With wdDoc.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWholeWord = True
.MatchCase = True
.Wrap = wdFindStop
.Text = Split(xlFList, "|")(i)
.Replacement.Text = Split(xlRList, "|")(i)
.Execute Replace:=wdReplaceAll
End With
End With
Next
'Close the document
wdDoc.Close SaveChanges:=True
'Get the next document
strFile = Dir()
End With
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

Function IsFileLocked(strFileName As String) As Boolean
On Error Resume Next
Open strFileName For Binary Access Read Write Lock Read Write As #1
Close #1
IsFileLocked = Err.Number
Err.Clear
End Function

[KippT]

Mr. Edstein,

That worked perfectly. It will save me quite a bit of time. I haven't had a chance to get into the code to see what was different yet so I may come back with some questions later. Thank you for your help.

Kipp

[macropod]

PS: For extra processing speed, you might want to change the first:
Application.ScreenUpdating = True
to:
Application.ScreenUpdating = False

[gmaxey]

I'm sure that Paul knows this and I'm not trying to be critical. Just be aware that the procedure provided will only find and replace in the main text story range. If you need to find and replace in all storyranges you can use the add-in available here: http://gregmaxey.mvps.org/word_tip_pages/vba_find_and_replace.html

[macropod]

Just be aware that the procedure provided will only find and replace in the main text story range.
True, though adding the extra functionality wouldn't be a major undertaking, either. The real challenge comes when someone starts asking for the code to work on some parts of a document and not others...