Set rng = ws.Range("B3", ws.Range("B3").End(-4121))

Sub EMBOLD_NEC_LIST(findText As String, replaceText As String)
  With ActiveDocument.Range.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = findText
    .Replacement.Text = replaceText
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute Replace:=wdReplaceAll
    .Text = replaceText
    .Replacement.Text = ""
    .Replacement.Font.Bold = True
    .Execute Replace:=wdReplaceAll
  End With
End Sub

Sub Demo()
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim iDataRow As Long, xlFList, i As Long
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\WordList.xlsx"
StrWkSht = "Sheet1"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
On Error Resume Next
'Start Excel
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
  MsgBox "Can't start Excel.", vbExclamation
  Exit Sub
End If
On Error GoTo 0
With xlApp
  'Hide our Excel session
  .Visible = False
  ' The file is available, so open it.
  Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm, ReadOnly:=True, AddToMru:=False)
  If xlWkBk Is Nothing Then
    MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
    .Quit
    Exit Sub
  End If
  ' Process the workbook.
  With xlWkBk
    'Ensure the worksheet exists
    If SheetExists(xlWkBk, StrWkSht) = True Then
      With .Worksheets(StrWkSht)
        ' Find the last-used row in column A.
        iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
        ' Capture the F/R 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))
          End If
        Next
      End With
    Else
      MsgBox "Cannot find the designated worksheet: " & StrWkSht, vbExclamation
    End If
  .Close False
  End With
  .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
'Exit if there are no data
If xlFList = "" Then Exit Sub
With ActiveDocument.Range.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Replacement.Font.Bold = True
  .Format = True
  .Wrap = wdFindContinue
  'Process each string from the List
  For i = 1 To UBound(Split(xlFList, "|"))
    .Text = Split(xlFList, "|")(i)
    .Replacement.Text = "^&"
    .Execute Replace:=wdReplaceAll
  Next
End With
Application.ScreenUpdating = True
End Sub

Function SheetExists(xlWkBk As Object, SheetName As String) As Boolean
Dim i As Long: SheetExists = False
For i = 1 To xlWkBk.Sheets.Count
  If xlWkBk.Sheets(i).Name = SheetName Then
    SheetExists = True:   Exit For
  End If
Next
End Function

    'Ensure the worksheet exists
'    If SheetExists(xlWkBk, StrWkSht) = True Then
      With .Worksheets(StrWkSht)
        ' Find the last-used row in column A.
        iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
        ' Capture the F/R 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))
          End If
        Next
      End With
'    Else
'      MsgBox "Cannot find the designated worksheet: " & StrWkSht, vbExclamation
'    End If

  'Process each string from the List
  For i = 1 To UBound(Split(xlFList, "|"))
    If UBound(Split(Split(xlFList, "|")(i), " ")) = 0 Then
      .MatchWholeWord = True
    Else
      .MatchWholeWord = False
    End If
    .Text = Split(xlFList, "|")(i)
    .Replacement.Text = "^&"
    .Execute Replace:=wdReplaceAll
  Next