Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 02-12-2018, 11:58 PM
qkjack qkjack is offline Find and highlight multiple words in MS Word document Windows 10 Find and highlight multiple words in MS Word document Office 2010 64bit
Novice
Find and highlight multiple words in MS Word document
 
Join Date: Feb 2018
Posts: 5
qkjack is on a distinguished road
Default Find and highlight multiple words in MS Word document

Through searching for older post, i found this formula below, however, as for the StrFnd part, it appears that there are too many words i entered inside the string and it split the rest to the next column and that makes the remain words exclude from the string. How can i alternate the formula so i can include a large amount of words in String for search. Thanks

Sub HiLightList()
Application.ScreenUpdating = False
Dim StrFnd As String, Rng As Range, i As Long
StrFnd = "dog,cat,pig,horse,man"
For i = 0 To UBound(Split(StrFnd, ","))
Set Rng = ActiveDocument.Range
With Rng.Find
.ClearFormatting
.Text = Split(StrFnd, ",")(i)
.Replacement.ClearFormatting
.Replacement.Highlight = True
.Replacement.Text = "^&"
.Forward = True
.Wrap = wdFindContinue


.Format = True
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = True
.Execute Replace:=wdReplaceAll
End With
Next
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub
Reply With Quote
  #2  
Old 02-13-2018, 01:33 AM
gmayor's Avatar
gmayor gmayor is offline Find and highlight multiple words in MS Word document Windows 10 Find and highlight multiple words in MS Word document Office 2016
Expert
 
Join Date: Aug 2014
Posts: 4,101
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

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
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote
  #3  
Old 02-13-2018, 08:03 PM
qkjack qkjack is offline Find and highlight multiple words in MS Word document Windows 10 Find and highlight multiple words in MS Word document Office 2010 64bit
Novice
Find and highlight multiple words in MS Word document
 
Join Date: Feb 2018
Posts: 5
qkjack is on a distinguished road
Default

Quote:
Originally Posted by gmayor View Post
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!
Reply With Quote
  #4  
Old 02-14-2018, 01:33 AM
gmayor's Avatar
gmayor gmayor is offline Find and highlight multiple words in MS Word document Windows 10 Find and highlight multiple words in MS Word document Office 2016
Expert
 
Join Date: Aug 2014
Posts: 4,101
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

Yes - For the first option, create a table in a Word document, for the second create an Excel workbook. They will work with Office 2010.
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote
  #5  
Old 02-14-2018, 07:24 PM
qkjack qkjack is offline Find and highlight multiple words in MS Word document Windows 10 Find and highlight multiple words in MS Word document Office 2010 64bit
Novice
Find and highlight multiple words in MS Word document
 
Join Date: Feb 2018
Posts: 5
qkjack is on a distinguished road
Default

Thanks for your help gmayor!

i have tried the code out, however, with this code ( sfName = "C:\Path\Find.docx") there is a message box saying something error '5174' and can not find document ( C:\Path\Find.docx). How should i solve this? Thanks alot
Reply With Quote
  #6  
Old 02-14-2018, 07:32 PM
qkjack qkjack is offline Find and highlight multiple words in MS Word document Windows 10 Find and highlight multiple words in MS Word document Office 2010 64bit
Novice
Find and highlight multiple words in MS Word document
 
Join Date: Feb 2018
Posts: 5
qkjack is on a distinguished road
Default

Or should i copy the location path in and replace it to the path part, and replace sfName.docx with Find.docx?
Reply With Quote
  #7  
Old 02-14-2018, 09:33 PM
gmayor's Avatar
gmayor gmayor is offline Find and highlight multiple words in MS Word document Windows 10 Find and highlight multiple words in MS Word document Office 2016
Expert
 
Join Date: Aug 2014
Posts: 4,101
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

"C:\Path\Find.docx" is the name and path of the document with the table. If you have named it something else, or stored it somewhere else, make the changes in the line
sfName = "C:\Path\Find.docx" to reflect what you have done,
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote
  #8  
Old 02-21-2018, 07:09 PM
qkjack qkjack is offline Find and highlight multiple words in MS Word document Windows 10 Find and highlight multiple words in MS Word document Office 2010 64bit
Novice
Find and highlight multiple words in MS Word document
 
Join Date: Feb 2018
Posts: 5
qkjack is on a distinguished road
Default

Sorry for the late reply. Thx GMAYOR it worked perfectly. Your are such a saviour!!
Reply With Quote
Reply

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Find and highlight multiple words in MS Word document Find and highlight multiple words in MS Word document AtaLoss Word VBA 37 09-22-2021 12:04 PM
Find and highlight multiple words in a document flatop Word VBA 3 04-16-2014 10:29 PM
Find and highlight multiple words in MS Word document Highlight and then replace multiple words redhin Word VBA 5 03-05-2013 05:42 AM
Find and highlight multiple words in MS Word document Find and highlight all words ending in -ly RBLampert Word VBA 13 10-23-2012 04:45 PM
find - reading highlight - highlight all / highlight doesn't stick when saved bobk544 Word 3 04-15-2009 03:31 PM

Other Forums: Access Forums

All times are GMT -7. The time now is 04:48 PM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft