Sub ReplaceFromSpreadsheet()

' Replace From XL Spreadsheet
' Paul Edstein

Application.ScreenUpdating = True
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim bStrt As Boolean, iDataRow As Long, bFound As Boolean, i As Long
Dim xlFExpr, xlRExpr, xlFWild, xlFFrmt, xlFBold, xlFItal, xlFUnln, xlFPnts, xlRBold, xlRItal, xlRUnln, xlRPnts, xlFNa, xlRNa, xlFClr, xlRClr



StrWkBkNm = "C:\Users\" & Environ("Username") & "\Desktop\BulkFindReplace.xlsx"


StrWkSht = "Sheet1"


If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
' 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
    ' Get the Find/Replace parameters.
    For i = 2 To iDataRow
    
    
      ' Skip over empty fields to preserve the underlying cell contents.
      If Trim(.Range("A" & i)) <> vbNullString Then
      
      
        xlFExpr = xlFExpr & "|" & Trim(.Range("A" & i))
        xlRExpr = xlRExpr & "|" & Trim(.Range("B" & i))
        xlFWild = xlFWild & "|" & Trim(.Range("C" & i))
        xlFFrmt = xlFFrmt & "|" & Trim(.Range("D" & i))
        
        
        ' =========  FIND FONT FORMATS
        
        
        xlFNa = xlFNa & "|" & Trim(.Range("E" & i))
        xlFClr = xlFClr & "|" & Trim(.Range("F" & i))
        xlFBold = xlFBold & "|" & Trim(.Range("G" & i))
        xlFItal = xlFItal & "|" & Trim(.Range("H" & i))
        xlFUnln = xlFUnln & "|" & Trim(.Range("I" & i))
        xlFPnts = xlFPnts & "|" & Trim(.Range("J" & i))
        
        
        ' ========= REPLACE FONT FORMATS
        
        xlRNa = xlRNa & "|" & Trim(.Range("K" & i))
        xlRClr = xlRClr & "|" & Trim(.Range("L" & i))
        xlRBold = xlRBold & "|" & Trim(.Range("M" & i))
        xlRItal = xlRItal & "|" & Trim(.Range("N" & i))
        xlRUnln = xlRUnln & "|" & Trim(.Range("O" & i))
        xlRPnts = xlRPnts & "|" & Trim(.Range("P" & 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 word from the F/R List


For i = 1 To UBound(Split(xlFExpr, "|"))
  With ActiveDocument.Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Format = CBool(Split(xlFFrmt, "|")(i))
      .MatchWildcards = False
      .MatchWholeWord = True
      .MatchCase = True
      If CBool(Split(xlFWild, "|")(i)) = True Then
        .MatchWildcards = True
        .MatchWholeWord = False
        .MatchCase = False
      End If
      
      
      
      With .Font
      
      '================== Is below Correct?
      
      
      
        If Split(xlFNa, "|")(i) <> "" Then .Name = Split(xlFNa, "|")(i)
        If Split(xlFClr, "|")(i) <> "" Then .Color = Split(xlClr, "|")(i)
        
        
        If Split(xlFBold, "|")(i) <> "" Then .Bold = CBool(Split(xlFBold, "|")(i))
        If Split(xlFItal, "|")(i) <> "" Then .Italic = CBool(Split(xlFItal, "|")(i))
        If Split(xlFUnln, "|")(i) <> "" Then .Underline = CBool(Split(xlFUnln, "|")(i))
        If Split(xlFPnts, "|")(i) <> "" Then .Size = Split(xlFPnts, "|")(i)
        
        
      End With
      
      
      
      With .Font
      
      '===================== Is this correct?
      
      
        If Split(xlRNa, "|")(i) <> "" Then .Name = Split(xlRNa, "|")(i)
        If Split(xlRClr, "|")(i) <> "" Then .Color = Split(xlRClr, "|")(i)
        
        
        If Split(xlRBold, "|")(i) <> "" Then .Bold = CBool(Split(xlRBold, "|")(i))
        If Split(xlRItal, "|")(i) <> "" Then .Italic = CBool(Split(xlRItal, "|")(i))
        If Split(xlRUnln, "|")(i) <> "" Then .Underline = CBool(Split(xlRUnln, "|")(i))
        If Split(xlRPnts, "|")(i) <> "" Then .Size = Split(xlRPnts, "|")(i)
      End With
      .Wrap = wdFindContinue
      .Text = Split(xlFExpr, "|")(i)
      .Replacement.Text = Split(xlRExpr, "|")(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