Microsoft Office Forums

Go Back   Microsoft Office Forums > Microsoft Word > Word VBA

Reply
 
LinkBack Thread Tools Display Modes
  #1  
Old 02-12-2018, 11:58 PM
qkjack qkjack is offline Windows 10 Office 2010 64bit
Novice
 
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 Windows 10 Office 2016
Expert
 
Join Date: Aug 2014
Posts: 2,379
gmayor is a jewel in the roughgmayor is a jewel in the roughgmayor is a jewel in the roughgmayor is a jewel in the rough
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)
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 Windows 10 Office 2010 64bit
Novice
 
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 Windows 10 Office 2016
Expert
 
Join Date: Aug 2014
Posts: 2,379
gmayor is a jewel in the roughgmayor is a jewel in the roughgmayor is a jewel in the roughgmayor is a jewel in the rough
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)
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 Windows 10 Office 2010 64bit
Novice
 
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 Windows 10 Office 2010 64bit
Novice
 
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 Windows 10 Office 2016
Expert
 
Join Date: Aug 2014
Posts: 2,379
gmayor is a jewel in the roughgmayor is a jewel in the roughgmayor is a jewel in the roughgmayor is a jewel in the rough
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)
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 Windows 10 Office 2010 64bit
Novice
 
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 AtaLoss Word VBA 33 10-10-2017 01:35 AM
Find and highlight multiple words in a document flatop Word VBA 3 04-16-2014 10:29 PM
Highlight and then replace multiple words redhin Word VBA 5 03-05-2013 05:42 AM
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


All times are GMT -7. The time now is 01:36 PM.


Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.
SEO by vBSEO ©2011, Crawlability, Inc.
MSOfficeForums.com is not affiliated with Microsoft