Macro To Identify & Highlight Words In MS Word Based Upon A List In Excel File Column

[abhimanyu]

Hi,
I am a writer and I have a list of words in Excel (adverbs, prepositions, cliches etc) that need to be identified and highlighted as I write in Word so I can edit them out when necessary.

I was looking for a solution and I was told the best one was a suitable Macros.

The Macros code for a very similar problem (identifying and replacing instead of identifying and highlighting) was given on a different thread, so I was hoping I could also get the code for a Macros that did the job I wanted.



Also, I searched for such a macros on other threads, but couldn't locate it. So if the answer has already been given elsewhere, I will be glad if I could be pointed to that thread.


Thanks in advance

[macropod]

Try, for example:

Sub BulkHighlighter()
Application.ScreenUpdating = False
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String
Dim iDataRow As Long, xlList As String, h As Long, i As Long
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\WordList.xlsx"
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(StrWkBkNm, False, True)
  If xlWkBk Is Nothing Then
    MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
    .Quit: Set xlApp = Nothing: Exit Sub
  End If
  ' Process the workbook.
  With xlWkBk
    With .Worksheets("Sheet1")
      ' 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
          xlList = xlList & "|" & Trim(.Range("A" & i))
        End If
      Next
    End With
  .Close False
  End With
  .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
'Exit if there are no data
If xlList = "" Then Exit Sub
h = Options.DefaultHighlightColorIndex
Options.DefaultHighlightColorIndex = wdBrightGreen
With ActiveDocument.Range.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .MatchWholeWord = True
  .MatchCase = True
  .Wrap = wdFindContinue
  .Replacement.Text = "^&"
  .Replacement.Highlight = True
  'Process each word from the List
  For i = 1 To UBound(Split(xlList, "|"))
    .Text = Split(xlList, "|")(i)
    .Execute Replace:=wdReplaceAll
  Next
End With
Options.DefaultHighlightColorIndex = h
Application.ScreenUpdating = True
End Sub

The macro assumes you're using an Excel workbook named 'WordList' stored in your 'Documents' folder and the list is in Column A of 'Sheet1'.
For PC macro installation & usage instructions, see: Installing Macros

[gmayor]

Another approach would be as follows. Name the column of Words (without empty cells and omitting the header row if any) as WordList. Then run the following to highlight the listed words. Change the value of strWorkbook as appropriate.


The Excel range is read into an array (without opening Excel) and that array is interrogated to get the words.

Sub Highlight_Words_From_Excel_NamedRange()
'Graham Mayor - https://www.gmayor.com - Last updated - 20 Mar 2020
Const strWorkbook As String = "C:\Path\Word List.xlsx" 'The workbook path
Const strRange As String = "WordList" 'The named Excel range
Dim arr() As Variant
Dim lngRows As Long
Dim oRng As Range
Dim strFind As String
    arr = xlFillArray(strWorkbook, strRange)
    For lngRows = 0 To UBound(arr, 2)
        strFind = arr(0, lngRows)
        Set oRng = ActiveDocument.Range
        With oRng.Find
            Do While .Execute(findText:=strFind)
                oRng.HighlightColorIndex = wdYellow
                oRng.Collapse 0
            Loop
        End With
    Next lngRows
lbl_Exit:
    Exit Sub
End Sub

Private Function xlFillArray(strWorkbook As String, _
                             strRange As String) As Variant
'Graham Mayor - http://www.gmayor.com - 24/09/2016
Dim RS As Object
Dim CN As Object
Dim iRows As Long

    strRange = strRange & "]"
    Set CN = CreateObject("ADODB.Connection")

    CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
                              "Data Source=" & strWorkbook & ";" & _
                              "Extended Properties=""Excel 12.0 Xml;HDR=NO;IMEX=1"""

    Set RS = CreateObject("ADODB.Recordset")
    RS.Open "SELECT * FROM [" & strRange, CN, 2, 1

    With RS
        .MoveLast
        iRows = .RecordCount
        .MoveFirst
    End With
    xlFillArray = RS.GetRows(iRows)
    If RS.State = 1 Then RS.Close
    Set RS = Nothing
    If CN.State = 1 Then CN.Close
    Set CN = Nothing
lbl_Exit:
    Exit Function
End Function

[abhimanyu]

Originally Posted by macropod

Try, for example:
...
The macro assumes you're using an Excel workbook named 'WordList' stored in your 'Documents' folder and the list is in Column A of 'Sheet1'.
For PC macro installation & usage instructions, see: Installing Macros

Thanks a lot Paul. Let me check this out.

[abhimanyu]

Originally Posted by gmayor

Another approach would be as follows. Name the column of Words (without empty cells and omitting the header row if any) as WordList. Then run the following to highlight the listed words. Change the value of strWorkbook as appropriate.


The Excel range is read into an array (without opening Excel) and that array is interrogated to get the words.

Thanks a ton Graham. Let me check this out as well.

[macropod]

I only just noticed your profile says you're using a Mac. In that case, you'll need to change the path and its separators to suit a Mac.
For Mac macro installation & usage instructions, see: Word:mac - Install a Macro