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