none
Macro code help: Highlighting all the occurence of words that once occurs in quotes. RRS feed

  • Question

  • Hello everyone,

    I'm running Microsoft Word 2010 off of a Dell laptop.

    I have a .docx (created on a Mac) with lots of information between quotes, " " like this that I would like to highlight any further occurrence of the same word with red. If that word doesn't occur again then I'll like to highlight the word between quotes with blue. I want to highlight the stuff between quotes, but nothing else.

    I don't know how to write code for macros at all. I do know the very basics of how they work. I can get to Visual Basic and understand how to create a new macro, but I'm pretty green with all of this.

    Is this action even possible?

    One other thing (in case it matters): I don't care for the fastest algorithm. I want this to help me with some editing and hence cold do even with a slow program.

    I would greatly appreciate any help you can offer.

    Thank you so much!

    Tuesday, April 15, 2014 1:54 PM

Answers

  • Try:

    Sub HighlightKeyTerms()
    Application.ScreenUpdating = False
    Dim Doc As Document, Rng As Range
    Dim StrTerms As String, strFnd As String
    Dim i As Long, j As Long
    Set Doc = ActiveDocument
    'Go through the document looking for defined terms.
    With Doc.Content
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        'Ensure all double quotes are properly formatted,
        'assuming that 'smart quotes' are in use.
        .Text = "[" & ChrW(8220) & Chr(147) & Chr(34) & Chr(148) & ChrW(8221) & "]"
        .Replacement.Text = """"
        .Format = False
        .Wrap = wdFindStop
        .MatchWholeWord = True
        .MatchWildcards = True
        .MatchCase = False
        .Execute Replace:=wdReplaceAll
        'Find terms between matched pairs of double quotes,
        'assuming that 'smart quotes' are in use.
        .Text = "[" & ChrW(8220) & Chr(147) & "]*[" & Chr(148) & ChrW(8221) & "]"
        .Execute
      End With
      Do While .Find.Found
        Set Rng = .Duplicate
        With Rng
          .Start = .Start + 1
          .End = .End - 1
          If InStr(StrTerms, vbCr & .Text & vbCr) = 0 Then StrTerms = StrTerms & .Text & vbCr
        End With
        .Find.Execute
      Loop
    End With
    'Exit if no defined terms have been found.
    If StrTerms = vbCr Then
      MsgBox "No defined terms found." & vbCr & "Aborting.", vbExclamation, "Defined Terms Error"
      GoTo ErrExit
    End If
    'Build the record count for each term in the StrTerms list.
    For i = 0 To UBound(Split(StrTerms, vbCr)) - 1
      strFnd = Trim(Split(StrTerms, vbCr)(i)): j = 0
      With Doc.Content
        With .Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Format = False
          .Text = strFnd
          .Wrap = wdFindStop
          .MatchWholeWord = True
          .MatchWildcards = False
          .MatchCase = True
          .Execute
        End With
        Do While .Find.Found
          'update the count.
            j = j + 1
          .Find.Execute
        Loop
      End With
      'Set the highlighting options for this instance
      If j = 1 Then
        Options.DefaultHighlightColorIndex = wdBlue
      Else
        Options.DefaultHighlightColorIndex = wdRed
      End If
      'Apply the highlighting
      With Doc.Content.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Format = False
        .Text = strFnd
        .Replacement.Text = "^&"
        .Replacement.Highlight = True
        .Wrap = wdFindStop
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchCase = True
        .Execute Replace:=wdReplaceAll
      End With
    Next i
    'Clean up and exit.
    ErrExit:
    Set Rng = Nothing: Set Doc = Nothing
    Application.ScreenUpdating = True
    End Sub


    Cheers
    Paul Edstein
    [MS MVP - Word]

    Tuesday, April 15, 2014 10:48 PM