Find & highlight first occurrence of each word from list in separate table file

[jish]

Would be grateful for help modifying the following macro (modified slightly from an original macro provided in a separate post by, I believe, "gmayor"---my gratitude to Mr. Mayor and my apologies for not appending this request to that original message. I've just spent 1/2 hour trying to locate that original posting but no luck...sigh.)

(1) Basically, this macro finds all occurrences of each word from a separate table file and highlights the word in yellow. I would like it to highlight just the first occurrence of the word, highlight it in yellow, and then start all over with the next word listed in the table.

(2) As icing on the cake, I would like to be able to segregate the table into sections, and have the first instance of each word from the first section of the table highlighted in yellow, the first occurrence of each word from the second section highlighted in green, those from the third section highlighted in blue, and so forth.

With thanks again for any help you can give, and special thanks to Mr. Mayor for his original posting. This is my first posting, so I hope I've done it correctly. Here's the macro:

Sub ReplaceFromTableList()
Dim oChanges As Document, oDoc As Document
Dim oTable As Table
Dim oRng As Range
Dim rFindText As Range
Dim i As Long
Dim sFname As String
Dim sAsk As String
sFname = "C:\Desktop\Test_list.doc"
Set oDoc = ActiveDocument
Set oChanges = Documents.Open(FileName:=sFname, Visible:=False)
Set oTable = oChanges.Tables(1)
For i = 1 To oTable.Rows.Count
Set oRng = oDoc.Range
Set rFindText = oTable.Cell(i, 1).Range
rFindText.End = rFindText.End - 1
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
Do While .Execute(FindText:=rFindText, _
MatchWholeWord:=True, _
MatchWildcards:=False, _
Forward:=True, _
Wrap:=wdFindStop) = True
oRng.HighlightColorIndex = wdYellow
oRng.Collapse wdCollapseEnd
Loop
End With
Next i
oChanges.Close wdDoNotSaveChanges
End Sub

[gmaxey]

Something like this. Use columns for the additional sections:

Sub ReplaceFromTableList()
Dim oChanges As Document, oDoc As Document
Dim oTable As Table
Dim oRng As Range
Dim rFindText As Range
Dim lngRow As Long, lngCol As Long, lngFound As Long
Dim sFname As String
Dim sAsk As String
  sFname = "D:\Source table.docm"
  Set oDoc = ActiveDocument
  Set oChanges = Documents.Open(FileName:=sFname, Visible:=False)
  Set oTable = oChanges.Tables(1)
  For lngCol = 1 To oTable.Columns.Count
    For lngRow = 1 To oTable.Rows.Count
      lngFound = 0
      Set oRng = oDoc.Range
      Set rFindText = oTable.Cell(lngRow, lngCol).Range
      rFindText.End = rFindText.End - 1
      With oRng.Find
        .Text = rFindText
        .ClearFormatting
        .Replacement.ClearFormatting
        .MatchWholeWord = True
        Do While .Execute
          lngFound = lngFound + 1
          Select Case lngCol
            Case 1: If lngFound = 1 Then oRng.HighlightColorIndex = wdYellow
            Case 2: If lngFound = 2 Then oRng.HighlightColorIndex = wdGreen
            Case 3: If lngFound = 3 Then oRng.HighlightColorIndex = wdBlue
            Case 4: If lngFound = 4 Then oRng.HighlightColorIndex = wdRed
          End Select
          oRng.Collapse wdCollapseEnd
          If lngFound = lngCol Then Exit Do
        Loop
      End With
    Next lngRow
  Next lngCol
   oChanges.Close wdDoNotSaveChanges
 End Sub

[jish]

Works like a charm! Thank you very, very much!

Something like this. Use columns for the additional sections:

Sub ReplaceFromTableList()
Dim oChanges As Document, oDoc As Document
Dim oTable As Table
Dim oRng As Range
Dim rFindText As Range
Dim lngRow As Long, lngCol As Long, lngFound As Long
Dim sFname As String
Dim sAsk As String
  sFname = "D:\Source table.docm"
  Set oDoc = ActiveDocument
  Set oChanges = Documents.Open(FileName:=sFname, Visible:=False)
  Set oTable = oChanges.Tables(1)
  For lngCol = 1 To oTable.Columns.Count
    For lngRow = 1 To oTable.Rows.Count
      lngFound = 0
      Set oRng = oDoc.Range
      Set rFindText = oTable.Cell(lngRow, lngCol).Range
      rFindText.End = rFindText.End - 1
      With oRng.Find
        .Text = rFindText
        .ClearFormatting
        .Replacement.ClearFormatting
        .MatchWholeWord = True
        Do While .Execute
          lngFound = lngFound + 1
          Select Case lngCol
            Case 1: If lngFound = 1 Then oRng.HighlightColorIndex = wdYellow
            Case 2: If lngFound = 2 Then oRng.HighlightColorIndex = wdGreen
            Case 3: If lngFound = 3 Then oRng.HighlightColorIndex = wdBlue
            Case 4: If lngFound = 4 Then oRng.HighlightColorIndex = wdRed
          End Select
          oRng.Collapse wdCollapseEnd
          If lngFound = lngCol Then Exit Do
        Loop
      End With
    Next lngRow
  Next lngCol
   oChanges.Close wdDoNotSaveChanges
 End Sub

[gmaxey]

You're welcome.