Try replacing the previous code with the following, which should suffice for doing bulk replacements or just the active document, plus the data on both worksheets:
Code:
Option Explicit
Dim strFolder As String, strFile As String, wdDoc As Document, i As Long
Dim xlApp As Object, xlWkBk As Object, bStrt As Boolean, bFound As Boolean
Dim xlFList1, xlRList1, xlFList2, xlRList2, lRow As Long, StrWkBkNm As String
Const StrWkSht1 As String = "Sheet1": Const StrWkSht2 As String = "Sheet2"
Sub ActiveDocFindReplace()
Application.ScreenUpdating = False
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\BulkFindReplace.xls"
If Dir(StrWkBkNm) = "" Then
MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
Exit Sub
End If
'Get the Find/Replace Data
Call GetData
'Process the document
Call UpdateDoc(ActiveDocument)
Application.ScreenUpdating = True
End Sub
Sub MultiDocFindReplace()
Application.ScreenUpdating = False
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\BulkFindReplace.xls"
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)
'Get the Find/Replace Data
Call GetData
'Process each document in the folder
While strFile <> ""
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
Call UpdateDoc(wdDoc)
'Close & save the document
wdDoc.Close SaveChanges:=True
'Get the next document
strFile = Dir()
Wend
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
Private Sub GetData()
' 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
'Initialize the F/R Lists
xlFList1 = "": xlRList1 = "": xlFList2 = "": xlRList2 = ""
' Process the workbook.
With xlWkBk.Worksheets(StrWkSht1).UsedRange
' Find the last-used row.
lRow = .Rows.Count
' Output the captured data.
For i = 1 To lRow
' Skip over empty fields to preserve the underlying cell contents.
If Trim(.Range("A" & i)) <> vbNullString Then
xlFList1 = xlFList1 & "|" & Trim(.Range("A" & i))
xlRList1 = xlRList1 & "|" & Trim(.Range("B" & i))
End If
Next
End With
With xlWkBk.Worksheets(StrWkSht2).UsedRange
' Find the last-used row.
lRow = .Rows.Count
' Output the captured data.
For i = 1 To lRow
' Skip over empty fields to preserve the underlying cell contents.
If Trim(.Range("A" & i)) <> vbNullString Then
xlFList2 = xlFList2 & "|" & .Range("A" & i)
xlRList2 = xlRList2 & "|" & .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
End Sub
Sub UpdateDoc(wdDoc As Document)
With wdDoc.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWholeWord = True
.MatchCase = True
.Wrap = wdFindContinue
'Process each word from the 1st F/R List
For i = 1 To UBound(Split(xlFList1, "|"))
.Text = Split(xlFList1, "|")(i)
.Replacement.Text = Split(xlRList1, "|")(i)
.Execute Replace:=wdReplaceAll
Next
.MatchWholeWord = False
.MatchCase = False
'Process each word from the 2nd F/R List
For i = 1 To UBound(Split(xlFList2, "|"))
.Text = Split(xlFList2, "|")(i)
.Replacement.Text = Split(xlRList2, "|")(i)
.Execute Replace:=wdReplaceAll
Next
'Process digits
For i = 0 To 9
.Text = Chr(48 + i)
.Replacement.Text = ChrW(1776 + i)
.Execute Replace:=wdReplaceAll
Next
End With
End Sub
Note: With the above code, you don't need to have the numbers in the workbook - there is a separate loop in the code for handling them automatically.
There are now just two subs that you run, either (a) ActiveDocFindReplace; or (b) MultiDocFindReplace.