Microsoft Word VBA Find And Replace from Excel file

wordfindreplaceexcel.vba

'excel file should have two columns, left being the find, right being the replace
'the find items should read like: [xxxx]

Sub ReplaceByExcel()
Dim xl As Object
Dim wb As Object
Dim ws As Object
Dim rng As Object
Dim cl As Object
Set xl = CreateObject("Excel.Application")
Dim filedialog As Office.filedialog, txtFileName
    Set filedialog = Application.filedialog(msoFileDialogFilePicker)
    txtFileName = ""
    With filedialog
        .AllowMultiSelect = False
        .Title = "Choose File(s)"
        .Filters.Add "Excel", "*.xls*"
        .Filters.Add "Csv", "*.csv*"
        .Filters.Add "Text", "*.txt*"
        .Filters.Add "All", "*.*"
    
        If .Show = True Then
            txtFileName = .SelectedItems(1)
        End If
        
    End With
    If Not txtFileName = "" Then

Set wb = xl.Workbooks.Open(txtFileName)
Set rng = wb.Sheets(1).Range("A2:A" & wb.Sheets(1).Cells(wb.Sheets(1).Rows.Count, "A").End(-4162).Row)
For Each cl In rng
    If Left(cl.Value, 1) = "[" Then
    If Right(cl.Value, 1) = "]" Then
    Call FindAndReplace(cl.Value, cl.Offset(0, 1).Value)
    End If
    End If
Next
End If
wb.Close
Set xl = Nothing
End Sub




Private Sub FindAndReplace(ByVal strFind As String, ByVal strReplace As String)
 
    Options.DefaultHighlightColorIndex = wdNoHighlight
    With ActiveDocument.Range.Find
      .Text = strFind
      .Replacement.Text = strReplace
      .Replacement.ClearFormatting
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
      .MatchCase = True
      .MatchWholeWord = True
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Replacement.Font.ColorIndex = 6
      .Execute Replace:=wdReplaceAll
    End With
  
End Sub