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!

  • Congratulations strongm 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

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.
 
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]
 
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
 
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]
 
 
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]
 
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?


 
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?

Cheers
Paul Edstein
[MS MVP - Word]
 
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. :)
 
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]
 
Status
Not open for further replies.

Part and Inventory Search

Sponsor

Back
Top