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.