Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Register Log in
  • Congratulations Mike Lewis on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Need to know how to build a Macro in Word that will do this please... 1

Status
Not open for further replies.
ewornibor

ewornibor

MIS
Feb 23, 2016
23
US
A friend of mine is looking to build a Document search for Rescinded words. That's the easy part. (He can find and highlight words). What he would like it to do is Find the word and have it change the font to red and be stricken through, the add a word after it in Blue and underlined. (Rescinded word / New Word). And maybe add a yellow Highlight over them all in one search.

Using Word 2013.

Thanks Everyone.
 
Sort by date Sort by votes
You could use either four different worksheets or four different workbooks, each with their own version of the macro. For each version of the macro, change:
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\BulkFindReplace.xlsx"
StrWkSht = "Sheet1"
to point to the correct workbook and/or worksheet and change:
.HighlightColorIndex = wdYellow
for whatever colour you want.

PS: When posting code, please use the code tags, indicated by the Code button on the posting menu.

Cheers
Paul Edstein
[MS MVP - Word]
 
Upvote 0 Downvote
Tried doing what you suggested, created a separate macro for each one (see below). It's not changing color like it should between each of them, all of them are highlighted the same color.

Code: 
Sub RescindedJointTerms()
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim iDataRow As Long, xlFList, xlRList, i As Long
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\RescindedJointTerms.xlsx"
StrWkSht = "Sheet1"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
On Error Resume Next
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
  MsgBox "Can't start Excel.", vbExclamation
  Exit Sub
End If
On Error GoTo 0
With xlApp
  'Hide our Excel session
  .Visible = False
  Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm, ReadOnly:=True, AddToMru:=False)
  If xlWkBk Is Nothing Then
    MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
    If bStrt = True Then .Quit
    Exit Sub
  End If
  ' Process the workbook.
  With xlWkBk.Worksheets(StrWkSht)
    ' Find the last-used row in column A.
    iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
    ' Output the captured data.
    For i = 1 To iDataRow
      ' Skip over empty fields to preserve the underlying cell contents.
      If Trim(.Range("A" & i)) <> vbNullString Then
        xlFList = xlFList & "|" & Trim(.Range("A" & i))
        xlRList = xlRList & "|" & Trim(.Range("B" & i))
      End If
    Next
  End With
  xlWkBk.Close False
  .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
' Process the data.
Application.ScreenUpdating = False

' Highlight & comment Rescinded Terms
For i = 1 To UBound(Split(xlFList, "|"))
  With ActiveDocument.Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .MatchWholeWord = True
      .MatchCase = False
      .Wrap = wdFindStop
      .Text = Split(xlFList, "|")(i)
      .Replacement.Text = ""
      .Execute
    End With
    Do While .Find.Found
      .HighlightColorIndex = wdBlue
      .Comments.Add Range:=.Duplicate, Text:=Split(xlRList, "|")(i)
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
Next
Application.ScreenUpdating = True
End Sub


Sub ArmyRescindedTerms()
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim iDataRow As Long, xlFList, xlRList, i As Long
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\ArmyRescindedTerms.xlsx"
StrWkSht = "Sheet1"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
On Error Resume Next
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
  MsgBox "Can't start Excel.", vbExclamation
  Exit Sub
End If
On Error GoTo 0
With xlApp
  'Hide our Excel session
  .Visible = False
  Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm, ReadOnly:=True, AddToMru:=False)
  If xlWkBk Is Nothing Then
    MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
    If bStrt = True Then .Quit
    Exit Sub
  End If
  ' Process the workbook.
  With xlWkBk.Worksheets(StrWkSht)
    ' Find the last-used row in column A.
    iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
    ' Output the captured data.
    For i = 1 To iDataRow
      ' Skip over empty fields to preserve the underlying cell contents.
      If Trim(.Range("A" & i)) <> vbNullString Then
        xlFList = xlFList & "|" & Trim(.Range("A" & i))
        xlRList = xlRList & "|" & Trim(.Range("B" & i))
      End If
    Next
  End With
  xlWkBk.Close False
  .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
' Process the data.
Application.ScreenUpdating = False

' Highlight & comment Rescinded Terms
For i = 1 To UBound(Split(xlFList, "|"))
  With ActiveDocument.Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .MatchWholeWord = True
      .MatchCase = False
      .Wrap = wdFindStop
      .Text = Split(xlFList, "|")(i)
      .Replacement.Text = ""
      .Execute
    End With
    Do While .Find.Found
      .HighlightColorIndex = wdRed
      .Comments.Add Range:=.Duplicate, Text:=Split(xlRList, "|")(i)
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
Next
Application.ScreenUpdating = True
End Sub


Sub ContentiousTerms()
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim iDataRow As Long, xlFList, xlRList, i As Long
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\ContentiousTerms.xlsx"
StrWkSht = "Sheet1"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
On Error Resume Next
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
  MsgBox "Can't start Excel.", vbExclamation
  Exit Sub
End If
On Error GoTo 0
With xlApp
  'Hide our Excel session
  .Visible = False
  Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm, ReadOnly:=True, AddToMru:=False)
  If xlWkBk Is Nothing Then
    MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
    If bStrt = True Then .Quit
    Exit Sub
  End If
  ' Process the workbook.
  With xlWkBk.Worksheets(StrWkSht)
    ' Find the last-used row in column A.
    iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
    ' Output the captured data.
    For i = 1 To iDataRow
      ' Skip over empty fields to preserve the underlying cell contents.
      If Trim(.Range("A" & i)) <> vbNullString Then
        xlFList = xlFList & "|" & Trim(.Range("A" & i))
        xlRList = xlRList & "|" & Trim(.Range("B" & i))
      End If
    Next
  End With
  xlWkBk.Close False
  .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
' Process the data.
Application.ScreenUpdating = False

' Highlight & comment Contentious Terms
For i = 1 To UBound(Split(xlFList, "|"))
  With ActiveDocument.Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .MatchWholeWord = True
      .MatchCase = False
      .Wrap = wdFindStop
      .Text = Split(xlFList, "|")(i)
      .Replacement.Text = ""
      .Execute
    End With
    Do While .Find.Found
      .HighlightColorIndex = wdYellow
      .Comments.Add Range:=.Duplicate, Text:=Split(xlRList, "|")(i)
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
Next
Application.ScreenUpdating = True
End Sub


Sub MiscellaneousTerms()
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim iDataRow As Long, xlFList, xlRList, i As Long
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\MiscellaneousTerms.xlsx"
StrWkSht = "Sheet1"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
On Error Resume Next
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
  MsgBox "Can't start Excel.", vbExclamation
  Exit Sub
End If
On Error GoTo 0
With xlApp
  'Hide our Excel session
  .Visible = False
  Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm, ReadOnly:=True, AddToMru:=False)
  If xlWkBk Is Nothing Then
    MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
    If bStrt = True Then .Quit
    Exit Sub
  End If
  ' Process the workbook.
  With xlWkBk.Worksheets(StrWkSht)
    ' Find the last-used row in column A.
    iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
    ' Output the captured data.
    For i = 1 To iDataRow
      ' Skip over empty fields to preserve the underlying cell contents.
      If Trim(.Range("A" & i)) <> vbNullString Then
        xlFList = xlFList & "|" & Trim(.Range("A" & i))
        xlRList = xlRList & "|" & Trim(.Range("B" & i))
      End If
    Next
  End With
  xlWkBk.Close False
  .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
' Process the data.
Application.ScreenUpdating = False

' Highlight & comment Rescinded Terms
For i = 1 To UBound(Split(xlFList, "|"))
  With ActiveDocument.Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .MatchWholeWord = True
      .MatchCase = False
      .Wrap = wdFindStop
      .Text = Split(xlFList, "|")(i)
      .Replacement.Text = ""
      .Execute
    End With
    Do While .Find.Found
      .HighlightColorIndex = wdGreen
      .Comments.Add Range:=.Duplicate, Text:=Split(xlRList, "|")(i)
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
Next
Application.ScreenUpdating = True
End Sub
 
Upvote 0 Downvote
The macros all function independently and have no effect on each others highlighting. Obviously, though, if you have the same term in multiple lists, whatever highlighting is done by the first macro with the term will be replaced by the highlighting of the later macro.

Cheers
Paul Edstein
[MS MVP - Word]
 
Upvote 0 Downvote
 
Upvote 0 Downvote
Since there are no data in any of your spreadsheets, how can you expect anyone to verify their content? As for the document, it has 'ContentiousTerms' highlighted in yellow, 'rescindedjoint' highlighted in blue, 'misc' highlighted in green and 'army' highlighted in red. So what's the problem?

Cheers
Paul Edstein
[MS MVP - Word]
 
Upvote 0 Downvote
Oh what is going on there WERE some terms in there...

When the macro was run, it wasn't highlighting the terms in the word document in the different colors, it was only using one color. So this should work the way it is coded then?


 
Upvote 0 Downvote
The document IS NOT all highlighted in one colour!

As I said:
As for the document, it has 'ContentiousTerms' highlighted in yellow, 'rescindedjoint' highlighted in blue, 'misc' highlighted in green and 'army' highlighted in red. So what's the problem?
Click to expand...

Cheers
Paul Edstein
[MS MVP - Word]
 
Upvote 0 Downvote
Should put a screenshot on here so you could see what I see in the Word document then. Weird stuff been going on today. Will have him test this next week.

Thank you for your help. :)
 
Upvote 0 Downvote
Maybe you should go to Review>Tracking and make sure the document view is set to either Original or Final, or make sure the Comments option is unchecked, under Show Markup.

Cheers
Paul Edstein
[MS MVP - Word]
 
Upvote 0 Downvote
Status
Not open for further replies.

Similar threads

duytoi
  • Locked
  • Question
How to add a head to the search results in Excel 2016 using VBA
Replies
2
Views
1K
Andrzejek
Andrzejek
jlr123
  • Locked
  • Question
Highlight (any) first text word that is a duplicate
Replies
2
Views
191
SkipVought
S
navyasree
  • Locked
  • Question
Need to update excel on making changes in visio flowcharts 1
Replies
4
Views
206
Andrzejek
Andrzejek
Metzke
  • Locked
  • Question
How to Transfer Licence to New PC
Replies
11
Views
431
teknance
teknance
lm1340
  • Question
Upload documents to Jira Cloud from SharePoint using Power Automate
Replies
0
Views
125
lm1340
lm1340

Part and Inventory Search

Sponsor

Back
Top