Sub BulkFindReplace()
Application.ScreenUpdating = True
Dim strFolder As String, strFile As String, wdDoc As Document
Dim TrkStatus As Boolean, StrTxt As String, Rng As Range, RngTmp As Range
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim bStrt As Boolean, iDataRow As Long, bFound As Boolean
Dim xlFList As String, xlRList As String, i As Long, Rslt
StrWkBkNm = "C:\Users\Macropod\Documents\Attachments\Temp\FindWords.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)
  With wdDoc
 
    'Store the current change-tracking status
    TrkStatus = .TrackRevisions
    'Ensure change-tracking is on
    .TrackRevisions = True
 
    Set Rng = .Range(0, 0)
    With .Range
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Format = False
        .MatchCase = True
        .MatchWholeWord = True
        .Wrap = wdFindContinue
 
        ' Process each word doc from the F/R List
        For i = 1 To UBound(Split(xlFList, "|"))
          .Text = Split(xlFList, "|")(i)
          .Replacement.Text = Split(xlRList, "|")(i)
          .Execute Replace:=wdReplaceAll
        Next
 
        'Update SSN, SSID & Date range formatting
        .Wrap = wdFindStop
        .MatchWildcards = True
        .Replacement.Text = ""
 
        'Fix SSNs
        'Ensure SSNs are correctly formatted with 'SSN' folowed by a colon, then a
        'single non-breaking space, followed by the number in the ##-####-### format
      End With
        .Start = Rng.Start
        .Collapse wdCollapseStart
        'First, work on unformatted SSNs
      With .Find
        .Text = "SSN[: ^0160]{1,}[0-9]{9}>"
        .Execute
      End With
      Do While .Find.Found
        'Ensure SSN is folowed by a colon, then a single non-breaking space
        .MoveStart wdCharacter, 3
        If Left(.Text, 1) <> ":" Then .InsertBefore ":"
        .MoveStart wdCharacter, 1
        Set RngTmp = .Characters.First
        With RngTmp
          If .Characters.First.Next Like "[ " & Chr(160) & "]" Then
            .MoveEndWhile " ", wdForward
            .MoveEndWhile Chr(160), wdForward
            .Text = Chr(160)
          ElseIf .Characters.First = " " Then
            .Text = Chr(160)
          End If
        End With
        'Hypenate the number with non-breaking hyphens
        .Start = .End - 7
        .End = .End - 3
        .InsertAfter Chr(30)
        .InsertBefore Chr(30)
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
      'Check that other SSNs that were correctly formatted as to the number
      'are also folowed by a colon, then a single non-breaking space
      .Start = Rng.Start
      .Collapse wdCollapseStart
      With .Find
        .Text = "SSN[: ]{1,}[0-9]{2}"
        .Execute
      End With
      Do While .Find.Found
        .MoveStart wdCharacter, 3
        If Left(.Text, 1) <> ":" Then .InsertBefore ":"
        .MoveStart wdCharacter, 1
        Set RngTmp = .Characters.First
        With RngTmp
          If .Characters.First.Next Like "[ " & Chr(160) & "]" Then
            .MoveEndWhile " ", wdForward
            .MoveEndWhile Chr(160), wdForward
            .Text = Chr(160)
          ElseIf .Characters.First = " " Then
            .Text = Chr(160)
          End If
        End With
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
 
      'Fix SSIDs
      'Ensure SSIDs are correctly formatted with 'SSN' folowed by a colon, then a
      'single non-breaking space, followed by the number in the ##-######## format
      .Start = Rng.Start
      .Collapse wdCollapseStart
      With .Find
        .Text = "SSID[: ^0160]{1,}[0-9]{10}>"
        .Execute
      End With
      Do While .Find.Found
        'Ensure SSID is folowed by a colon, then a single non-breaking space
        .MoveStart wdCharacter, 4
        If Left(.Text, 1) <> ":" Then .InsertBefore ":"
        .MoveStart wdCharacter, 1
        Set RngTmp = .Characters.First
        With RngTmp
          If .Characters.First.Next Like "[ " & Chr(160) & "]" Then
            .MoveEndWhile " ", wdForward
            .MoveEndWhile Chr(160), wdForward
            .Text = Chr(160)
          ElseIf .Characters.First = " " Then
            .Text = Chr(160)
          End If
        End With
        'Hypenate the number with a non-breaking hyphen
        .Start = .End - 8
        .InsertBefore Chr(30)
        'Ensure there is provision for the approval date:
        Set RngTmp = .Characters.Last
        RngTmp.MoveEnd wdCharacter, 30
        If InStr(RngTmp, "Approved") = 0 Then
          .Collapse wdCollapseEnd
          .Text = " (Approved:   /   /   )"
        End If
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
      'Check that other SSIDs that were correctly formatted as to the number
      'are also folowed by a colon, then a single non-breaking space
      .Start = Rng.Start
      .Collapse wdCollapseStart
      With .Find
        .Text = "SSID[: ]{1,}[0-9]{2}"
        .Execute
      End With
      Do While .Find.Found
        .MoveStart wdCharacter, 4
        If Left(.Text, 1) <> ":" Then .InsertBefore ":"
        .MoveStart wdCharacter, 1
        Set RngTmp = .Characters.First
        With RngTmp
          If .Characters.First.Next Like "[ " & Chr(160) & "]" Then
            .MoveEndWhile " ", wdForward
            .MoveEndWhile Chr(160), wdForward
            .Text = Chr(160)
          ElseIf .Characters.First = " " Then
            .Text = Chr(160)
          End If
        End With
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
 
      'Fix Date Ranges
      .Start = Rng.Start
      .Collapse wdCollapseStart
      With .Find
        .Text = "[0-9]{1,2}/[0-9]{1,2}/[0-9]{4}-[0-9]{1,2}/[0-9]{1,2}/[0-9]{4}"
        .Execute
      End With
      Do While .Find.Found
        Select Case Trim(LCase(.Words.First.Previous.Previous.Words.First))
          Case "between": StrTxt = " and "
          Case "from": StrTxt = " to "
          Case "of": StrTxt = " through "
        End Select
        .Start = .Start + InStr(.Text, "-") - 1
        .End = .Start + 1
        .Duplicate.Text = StrTxt
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
 
      'Check that all other inter-numeral hyphens are non-breaking
      .Start = Rng.Start
      .Collapse wdCollapseStart
      With .Find
        .Text = "[0-9][^45^0150^0151][0-9]"
        .Execute
      End With
      Do While .Find.Found
        .MoveStart wdCharacter, 1
        .MoveEnd wdCharacter, -1
        If .Text <> Chr(30) Then .Text = Chr(30)
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
    End With
 
    'Restore the original change tracking status
    .TrackRevisions = TrkStatus
    'Close & save the document
    .Close SaveChanges:=True
  End With
 
  'Get the next document
  strFile = Dir()
Wend
Set Rng = Nothing: Set RngTmp = Nothing
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