02-13-2018, 08:03 PM
|
Novice
|
|
Join Date: Feb 2018
Posts: 5
|
|
Quote:
Originally Posted by gmayor
Put the words in the first column of a table and save the document (sfName). Then use the following:
Code:
Sub HiLightFromTableList()
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:\Path\Find.docx"
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
Do While .Execute(FindText:=rFindText, _
MatchCase:=False, _
MatchWholeWord:=True, _
MatchWildcards:=False, _
Forward:=True, _
Wrap:=wdFindStop) = True
oRng.HighlightColorIndex = wdTurquoise
oRng.Collapse wdCollapseEnd
Loop
End With
DoEvents
Next i
oChanges.Close wdDoNotSaveChanges
lbl_Exit:
Exit Sub
End Sub
Or if you want to be more adventurous put the words in Column A of an Excel worksheet (with a header row and no empty rows) and use the following:
Code:
Sub Macro1()
Const strWorkbook As String = "C:\Path\Highlight.xlsx"
Const strSheet As String = "Sheet1"
Dim strFind As String
Dim oRng As Range
Dim i As Long
Dim Arr() As Variant
Arr = xlFillArray(strWorkbook, strSheet)
For i = 0 To UBound(Arr, 2)
strFind = Arr(0, i)
Set oRng = ActiveDocument.Range
With oRng.Find
Do While .Execute(FindText:=strFind, _
MatchCase:=False, _
MatchWholeWord:=True, _
MatchWildcards:=False, _
Forward:=True, _
Wrap:=wdFindStop) = True
oRng.HighlightColorIndex = wdTurquoise
oRng.Collapse wdCollapseEnd
Loop
End With
DoEvents
Next i
Set oRng = Nothing
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 & "$]" 'Use this to work with a named worksheet
'strRange = strRange & "]" 'Use this to work with a named range
Set CN = CreateObject("ADODB.Connection")
'Set HDR=NO for no header row
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
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
|
For the first formula, did u mean create a table in word or in excel? I am using word2010 does these code work with it? Thanks a lot gmayor!
|