macro fails on 2nd run

Hi All,

I have a longish userform macro in Word that highlights defined terms in legal documents in different colors depending on if they are defined more than once (in quotes), defined but not used, and then every instance of the term.

This all works perfectly on the first run of a document, however, if I run it again on a 2nd document, it jumps out of one of the loops and goes to the next phase of the routine, ending prematurely.

If I close and restart Word, it runs perfectly again, but fails on 2nd attempt. It appears to fail when changing from the main story to the footnote story (highlighted in red) below. This is just the bit of code where it fails - please let me know if anyone would like to see the whole thing.

Has anyone had a similar issue? Many thanks for any help!

Code:

---

With Selection
    .HomeKey wdStory
 
 
        'highlight all copies yellow
 
    With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        Do While .Execute(FindText:=StrFind2, _
            MatchCase:=False, MatchWholeWord:=False, MatchWildcards:=False, _
            Wrap:=wdFindStop, Forward:=True) = True
            Set oRng = Selection.Range
            oRng.HighlightColorIndex = wdYellow
            i = i + 1
            ActiveDocument.UndoClear
        Loop
     
If ActiveDocument.Footnotes.Count >= 1 Then
 
     
            ActiveDocument.StoryRanges(wdFootnotesStory).Select
         
        Do While .Execute(FindText:=StrFind2, _
            MatchCase:=False, MatchWholeWord:=False, MatchWildcards:=False, _
            Wrap:=wdFindStop, Forward:=True) = True
            Set oRng = Selection.Range
            oRng.HighlightColorIndex = wdYellow
            i = i + 1
            ActiveDocument.UndoClear
        Loop
End If
 
ActiveDocument.StoryRanges(wdMainTextStory).Select

---

Try using a variable set to Active Document

Code:

---

Dim TheDoc as Object

'Near the top of your Code
Set TheDoc = ActiveDocument

---

Replace all other instances of "ActiveDocument" in code with "TheDoc"

To make that work reliably, one would also need to replace:

Code:

---

With Selection
    .HomeKey wdStory

---

with:

Code:

---

With TheDoc

---

Quote:

---

Originally Posted by SamT

Try using a variable set to Active Document

Code:

---

Dim TheDoc as Object

'Near the top of your Code
Set TheDoc = ActiveDocument

---

Replace all other instances of "ActiveDocument" in code with "TheDoc"

---

Thank you - just tried it, but still having the same issue . . .

Unfortunately, you haven't posted enough of your code to diagnose the issue. Try something along the lines of:

Code:

---

Sub Demo()
Application.ScreenUpdating = False
Dim wdDoc As Document, StrFnd As String, i As Long
Set wdDoc = ActiveDocument
StrFnd = InputBox("Text to find")
If Trim(StrFnd) = "" Then Exit Sub
With wdDoc
  i = i + Counter(StrFnd, .StoryRanges(wdMainTextStory))
  i = i + Counter(StrFnd, .StoryRanges(wdFootnotesStory))
  .UndoClear
End With
MsgBox i
Application.ScreenUpdating = True
End Sub


Function Counter(StrFnd As String, Rng As Range) As Long
Dim i As Long
With Rng
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    Do While .Execute(FindText:=StrFnd, _
      MatchCase:=False, MatchWholeWord:=False, MatchWildcards:=False, _
        Wrap:=wdFindStop, Forward:=True) = True
      .Parent.HighlightColorIndex = wdYellow
      i = i + 1
    Loop
  End With
End With
Counter = i
End Function

---

Quote:

---

Originally Posted by macropod

Unfortunately, you haven't posted enough of your code to diagnose the issue.

---

Thanks so much for your assistance! The procedure is quite long, so not sure how much to post . . .

It finds a start quote, extends to the end quote, puts the term in a variable, and loops through every term in the document, first those in the main story, then starting again from the footnotes, if the term is defined there. It highlights if defined more than once (in quotes more than once - turquoise), each instance without quotes (yellow), and if defined, but not used (in quotes, but never used again - red).

The big question for me is why it would work correctly on any document once, even in documents 100's of pages long, but then require a fresh process of Word to run correctly a 2nd time.

Based on your description, try:

Code:

---

Option ExplicitDim StrTerms As String, i As Long, j As Long, bFnd As Boolean


Sub Demo()
Application.ScreenUpdating = False
Dim StrFnd As String
StrTerms = "|"
With ActiveDocument
  Call GetTerms(.StoryRanges(wdMainTextStory))
  If .Footnotes.Count > 0 Then Call GetTerms(.StoryRanges(wdFootnotesStory))
  StrTerms = Replace(Replace(StrTerms, "“", ""), "”", "")
  For i = UBound(Split(StrTerms, "|")) - 1 To 1 Step -1
    j = 0: StrFnd = Split(StrTerms, "|")(i)
    Call RngTag(.StoryRanges(wdMainTextStory), StrFnd)
    If .Footnotes.Count > 0 Then Call RngTag(.StoryRanges(wdFootnotesStory), StrFnd)
    If j = 0 Then
      StrTerms = Replace(StrTerms, StrFnd & "|", "")
    End If
  Next
  For i = 1 To UBound(Split(StrTerms, "|")) - 1
    StrFnd = Split(StrTerms, "|")(i)
    Call TermTag(.StoryRanges(wdMainTextStory), StrFnd)
    If .Footnotes.Count > 0 Then
      If bFnd = False Then Call TermTag(.StoryRanges(wdFootnotesStory), StrFnd)
    End If
  Next
End With
Application.ScreenUpdating = True
End Sub


Sub GetTerms(Rng As Range)
Options.DefaultHighlightColorIndex = wdRed
With Rng
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Format = True
    .Forward = True
    .MatchWildcards = True
    .Wrap = wdFindContinue
    .Text = """"
    .Replacement.Text = "^&"
    .Execute Replace:=wdReplaceAll
    .Text = "“*”"
    .Replacement.Text = "^&"
    .Replacement.Highlight = True
    .Execute Replace:=wdReplaceAll
    .Format = False
    .Wrap = wdFindStop
  End With
  Do While .Find.Execute
    If InStr(StrTerms, .Text) = 0 Then
      StrTerms = StrTerms & .Text & "|"
    Else
      .HighlightColorIndex = wdTurquoise
    End If
    .Collapse wdCollapseEnd
  Loop
End With
End Sub


Sub RngTag(Rng As Range, StrFnd As String)
With Rng
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Format = False
    .Forward = True
    .MatchWildcards = True
    .Text = "[!“]" & StrFnd & "[!”]"
    .Wrap = wdFindStop
  End With
  Do While .Find.Execute
    j = j + 1
    .Start = .Start + 1
    .End = .End - 1
    .HighlightColorIndex = wdYellow
    .Collapse wdCollapseEnd
  Loop
End With
End Sub


Sub TermTag(Rng As Range, StrFnd As String)
bFnd = False
With Rng
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Format = False
    .Forward = True
    .MatchWildcards = True
    .Text = "“" & StrFnd & "”"
    .Wrap = wdFindStop
    .Execute
  End With
  If .Find.Found Then
    .HighlightColorIndex = wdYellow
    bFnd = True
  End If
End With
End Sub

---

Quote:

---

Originally Posted by macropod

Based on your description, try:

---

Paul, sorry for the late response - been crazy at work . . . thank you so much for writing this, but I couldn't get it to run . . . my VBA skills are rudimentary, at best. Here's the whole code - I'll cut out the footnote section, which is basically the same, but starts in the footnotes, in case a term is defined there. Hope it's not too long!

Code:

---

Sub HighlightDefs()
HighlightWork1.Show vbModeless
End Sub
 
 
Private Sub cmdAll_Click()
 
        '1. Highlight Defined Terms
 
Dim i As Integer
Dim j As Integer
Dim R1 As Integer
Dim R2 As Integer
Dim R3 As Integer
Dim r4 As Integer
Dim oRng As Word.Range
Dim oRng2 As Word.Range
Dim NumCharsBefore As Long, NumCharsAfter As Long, LengthsAreEqual As Boolean
Dim StrFind As String
Dim StrReplace As String
Dim StrReplace2 As String
Dim StrFind2 As String
Dim Length As Integer
Dim varText As String
Dim myRange As Range
 
Dim char As String
Dim myNum As Integer
Dim myNum2 As Integer
Dim myNum3 As Integer
 
Dim bSmtQt As Boolean
 
 
i = 0
j = 0
R1 = 0
R2 = 0
R3 = 0
r4 = 0
 
Dim nCount As Long
    nCount = 0
 
ActiveDocument.UndoClear
 
 
On Error GoTo Out3
 
ActiveDocument.ActiveWindow.View.Type = wdPrintView
 
 
'Application.ScreenUpdating = False
 
        'replace straight quotes with smart quotes
 
bSmtQt = Options.AutoFormatAsYouTypeReplaceQuotes
Options.AutoFormatAsYouTypeReplaceQuotes = True
With ActiveDocument.Range.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = """"
  .Replacement.Text = """"
  .Forward = True
  .Wrap = wdFindStop
  .Format = False
  .MatchCase = False
  .MatchWholeWord = False
  .MatchWildcards = False
  .MatchSoundsLike = False
  .MatchAllWordForms = False
  .Execute Replace:=wdReplaceAll
End With
 
 
 
If ActiveDocument.Footnotes.Count >= 1 Then
 
ActiveDocument.StoryRanges(wdFootnotesStory).Select
 
 
With Selection.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = """"
  .Replacement.Text = """"
  .Forward = True
  .Wrap = wdFindStop
  .Format = False
  .MatchCase = False
  .MatchWholeWord = False
  .MatchWildcards = False
  .MatchSoundsLike = False
  .MatchAllWordForms = False
  .Execute Replace:=wdReplaceAll
End With
Options.AutoFormatAsYouTypeReplaceQuotes = bSmtQt
 
 
End If

 
With Selection
    .HomeKey wdStory
End With
 
    'find unmatched quotes
 
Dim oPara As Paragraph
For Each oPara In ActiveDocument.Paragraphs
  With oPara.Range
    If (Len(.Text) - Len(Replace(.Text, Chr(34), vbNullString))) Mod 2 <> 0 Then
      .Select
      MsgBox "Selected paragraph has unmatched plain quotes", vbExclamation
     
        If varText = vbOK Then
            Exit Sub
        End If
 
      Unload Me
    Exit Sub
    End If
    If Len(Replace(.Text, Chr(147), vbNullString)) <> Len(Replace(.Text, Chr(148), vbNullString)) Then
      .Select
      MsgBox "Selected paragraph has unmatched smart quotes", vbExclamation
     
        If varText = vbOK Then
            Exit Sub
        End If
 
      Unload Me
    Exit Sub
    End If
  End With
Next
 
 
Dim oFoot As Footnote
For Each oFoot In ActiveDocument.Footnotes
  With oFoot.Range
    If (Len(.Text) - Len(Replace(.Text, Chr(34), vbNullString))) Mod 2 <> 0 Then
      .Select
      MsgBox "Selected paragraph has unmatched plain quotes", vbExclamation
     
        If varText = vbOK Then
            Exit Sub
        End If
 
      Unload Me
    Exit Sub
    End If
    If Len(Replace(.Text, Chr(147), vbNullString)) <> Len(Replace(.Text, Chr(148), vbNullString)) Then
      .Select
      MsgBox "Selected paragraph has unmatched smart quotes", vbExclamation
     
        If varText = vbOK Then
            Exit Sub
        End If
 
      Unload Me
    Exit Sub
    End If
  End With
Next
 
 
ActiveDocument.UndoClear
 
i = 0
 
        'insert text to mark end of replacements
 
    Selection.HomeKey unit:=wdStory
    Selection.TypeText Text:=Chr(147) & "xyxy" & Chr(148) & " "
 
 
Do
 
        'A. find quote for next term
 
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "^0147"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
 
Set myRange = Selection.Range
 
 
If Selection.Range.HighlightColorIndex = wdTurquoise Then
    With Selection.Find
        .Text = "^0148"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
 
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "^0147"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
Else
End If

 
        '2. find close quote and select
 
    Selection.Extend
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "^0148"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
   
   
    Selection.ExtendMode = False
   
 
StrFind = Selection.Text
StrReplace = Selection.Text
Length = Len(StrReplace) - 2
 
 
        'set second variable for plural
 
If Length > 1 Then
StrFind2 = Mid$(StrReplace, 1, Length) & Chr(148)
StrReplace2 = Mid$(StrReplace, 1, Length) & Chr(148)
Else
End If
 
        'skip certain words
 
If Mid$(StrFind, 2, 2) = "or" And Len(StrFind) = 4 Then
    Selection.Collapse Direction:=wdCollapseEnd
    GoTo Skip
End If
 
If Mid$(StrFind, 2, 3) = "or," And Len(StrFind) = 5 Then
    Selection.Collapse Direction:=wdCollapseEnd
    GoTo Skip
End If
 
If Mid$(StrFind, 2, 2) = "to" And Len(StrFind) = 4 Then
    Selection.Collapse Direction:=wdCollapseEnd
    GoTo Skip
End If
 
If Mid$(StrFind, 2, 3) = "to," And Len(StrFind) = 5 Then
    Selection.Collapse Direction:=wdCollapseEnd
    GoTo Skip
End If
 
If Len(StrFind) = 3 Then
    Selection.Collapse Direction:=wdCollapseEnd
    GoTo Skip
End If
 
If Mid$(StrFind, 2, 3) = "and" And Len(StrFind) = 5 Then
    Selection.Collapse Direction:=wdCollapseEnd
    GoTo Skip
End If
 
If Mid$(StrFind, 2, 4) = "and," And Len(StrFind) = 6 Then
    Selection.Collapse Direction:=wdCollapseEnd
    GoTo Skip
End If
 
If Mid$(StrFind, 2, 3) = "our" And Len(StrFind) = 5 Then
  Selection.Collapse Direction:=wdCollapseEnd
    GoTo Skip
End If
 
If Mid$(StrFind, 2, 4) = "our," And Len(StrFind) = 6 Then
    Selection.Collapse Direction:=wdCollapseEnd
    GoTo Skip
End If
 
If Mid$(StrFind, 2, 2) = "we" And Len(StrFind) = 4 Then
    Selection.Collapse Direction:=wdCollapseEnd
    GoTo Skip
End If
 
If Mid$(StrFind, 2, 3) = "we," And Len(StrFind) = 5 Then
    Selection.Collapse Direction:=wdCollapseEnd
    GoTo Skip
End If
 
If Mid$(StrFind, 2, 2) = "us" And Len(StrFind) = 4 Then
    Selection.Collapse Direction:=wdCollapseEnd
    GoTo Skip
End If
 
If Mid$(StrFind, 2, 3) = "us," And Len(StrFind) = 5 Then
    Selection.Collapse Direction:=wdCollapseEnd
    GoTo Skip
End If
 
 
 
      Set myRange = Selection.Range
   
   
        'check if back at the beginning
   
If myRange = Chr(147) & "xyxy" & Chr(148) _
Or myRange = Chr(147) & "Xyxy" & Chr(148) _
Or myRange = Chr(147) & "XYXY" & Chr(148) Then
    GoTo Skip3
Else
End If
   
     

        'skip if string is too long
 
If Len(StrFind) > 254 Then
    Selection.Collapse Direction:=wdCollapseEnd
    GoTo Skip
Else
End If
 
 
With Selection
    .HomeKey wdStory
 
        'replace terms defined more than once
 
    With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        Do While .Execute(FindText:=StrFind, _
            MatchCase:=False, MatchWholeWord:=True, MatchWildcards:=False, _
            Wrap:=wdFindStop, Forward:=True) = True
            Set oRng = Selection.Range
            oRng.HighlightColorIndex = wdTurquoise
            i = i + 1
            ActiveDocument.UndoClear
        Loop
 
     
            Selection.HomeKey wdStory
         
        Do While .Execute(FindText:=StrFind2, _
            MatchCase:=False, MatchWholeWord:=True, MatchWildcards:=False, _
            Wrap:=wdFindStop, Forward:=True) = True
            Set oRng2 = Selection.Range
            oRng2.HighlightColorIndex = wdTurquoise
            j = j + 1
            ActiveDocument.UndoClear
        Loop
 
 
If ActiveDocument.Footnotes.Count >= 1 Then
 
            ActiveDocument.StoryRanges(wdFootnotesStory).Select
           
            Selection.HomeKey
         
            Do While .Execute(FindText:=StrFind, _
                MatchCase:=False, MatchWholeWord:=True, MatchWildcards:=False, _
                Wrap:=wdFindStop, Forward:=True) = True
                Set oRng = Selection.Range
                oRng.HighlightColorIndex = wdTurquoise
                i = i + 1
                ActiveDocument.UndoClear
            Loop
         
            Selection.HomeKey
         
            Do While .Execute(FindText:=StrFind2, _
                MatchCase:=False, MatchWholeWord:=True, MatchWildcards:=False, _
                Wrap:=wdFindStop, Forward:=True) = True
                Set oRng2 = Selection.Range
                oRng2.HighlightColorIndex = wdTurquoise
                j = j + 1
                ActiveDocument.UndoClear
            Loop
End If
 
 
ActiveDocument.StoryRanges(wdMainTextStory).Select
 
Selection.HomeKey
 
 
R1 = i
R3 = j
 
        'remove highlighting if defined just once
 
If i > 0 And j > 0 Then

ElseIf i <= 1 And j = 0 Then
oRng.HighlightColorIndex = wdNone
ElseIf i = 0 And j <= 1 Then
oRng2.HighlightColorIndex = wdNone
Else
End If
 
    End With
End With
 
i = 0
j = 0
 
        'C. go back to last term
 
  myRange.Select
 
    Selection.MoveLeft unit:=wdCharacter, Count:=1
 
 
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "^0147"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
 
 
    Selection.MoveRight unit:=wdCharacter, Count:=1
    Selection.Extend
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "^0148"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
 
 
    Selection.MoveLeft unit:=wdCharacter, Count:=1
 
 
    Selection.ExtendMode = False
   
 
StrFind = Selection.Text
StrReplace = Selection.Text
 
 
        'shorten selection by one character to handle plurals
 
    If Len(StrReplace) > 3 Then
        Length = Len(StrReplace) - 1
    Else
        Length = Len(StrReplace)
    End If
 
StrFind2 = Mid$(StrReplace, 1, Length)
StrReplace2 = Mid$(StrReplace, 1, Length)
 
  Set myRange = Selection.Range
 
 
With Selection
    .HomeKey wdStory
 
 
        'highlight all copies yellow
 
    With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        Do While .Execute(FindText:=StrFind2, _
            MatchCase:=False, MatchWholeWord:=False, MatchWildcards:=False, _
            Wrap:=wdFindStop, Forward:=True) = True
            Set oRng = Selection.Range
            oRng.HighlightColorIndex = wdYellow
            i = i + 1
            ActiveDocument.UndoClear
        Loop
     
If ActiveDocument.Footnotes.Count >= 1 Then
 
     
            ActiveDocument.StoryRanges(wdFootnotesStory).Select
         
        Do While .Execute(FindText:=StrFind2, _
            MatchCase:=False, MatchWholeWord:=False, MatchWildcards:=False, _
            Wrap:=wdFindStop, Forward:=True) = True
            Set oRng = Selection.Range
            oRng.HighlightColorIndex = wdYellow
            i = i + 1
            ActiveDocument.UndoClear
        Loop
End If
 
ActiveDocument.StoryRanges(wdMainTextStory).Select
 
R2 = i
 
    End With
End With
 
 

        'check if term defined, but not used, and highlight red
 
If R2 = R1 + R3 Then
 
With Selection
    .HomeKey wdStory
 
    With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        Do While .Execute(FindText:=StrFind2, _
            MatchCase:=False, MatchWholeWord:=False, MatchWildcards:=False, _
            Wrap:=wdFindStop, Forward:=True) = True
            Set oRng = Selection.Range
            oRng.HighlightColorIndex = wdRed
            i = i + 1
            ActiveDocument.UndoClear
        Loop
     
If ActiveDocument.Footnotes.Count >= 1 Then
     
            ActiveDocument.StoryRanges(wdFootnotesStory).Select
         
            Selection.HomeKey
         
        Do While .Execute(FindText:=StrFind2, _
            MatchCase:=False, MatchWholeWord:=False, MatchWildcards:=False, _
            Wrap:=wdFindStop, Forward:=True) = True
            Set oRng = Selection.Range
            oRng.HighlightColorIndex = wdRed
            i = i + 1
            ActiveDocument.UndoClear
        Loop
End If
 
 
ActiveDocument.StoryRanges(wdMainTextStory).Select
 
End With
End With
 
End If
 
 
i = 0
R1 = 0
R2 = 0
 
  myRange.Select
 
 
If myRange = Chr(147) & "xyxy" & Chr(148) _
Or myRange = Chr(147) & "Xyxy" & Chr(148) _
Or myRange = Chr(147) & "XYXY" & Chr(148) Then
GoTo Skip3
Else
End If
 
 
    Selection.MoveRight unit:=wdCharacter, Count:=1
 
Skip:
 
ActiveDocument.UndoClear
 
 
Loop
 
 

 
Skip3:

'FOOTNOTE LOOP

 
SkipFootnote:
 

 
Set oRng = Nothing
Set oRng2 = Nothing
StrFind = vbNullString
StrReplace = vbNullString
StrReplace2 = vbNullString
StrFind2 = vbNullString
char = vbNullString
 
 
Call ClearFindAndReplaceParameters
 
Skip2:
 
        'insert text box in header
 
    Selection.HomeKey unit:=wdStory
    Selection.MoveRight unit:=wdWord, Count:=3, Extend:=wdExtend
    Selection.Delete unit:=wdCharacter, Count:=1
 
    If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
 
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.HeaderFooter.Shapes.AddTextbox(msoTextOrientationHorizontal, _
        99#, 28.8, 144#, 171#).Select
    Selection.ShapeRange.TextFrame.TextRange.Select
    Selection.Collapse
    Selection.TypeText Text:="cyan quotes = term defined more than once"
    Selection.TypeParagraph
    Selection.TypeText Text:="yellow = all instances of defined term"
    Selection.TypeParagraph
    Selection.TypeText Text:="red = term defined, but not used"
    Selection.TypeParagraph
    Selection.TypeText Text:="purple = possible undefined terms"
    Selection.TypeParagraph
    Selection.TypeText Text:="green = fields and selected references"
 
        Selection.WholeStory
    Selection.Font.Size = 8
    Selection.ShapeRange.Select
    Selection.ShapeRange.Fill.Visible = msoTrue
    Selection.ShapeRange.Fill.Solid
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 255)
    Selection.ShapeRange.Fill.Transparency = 0#
    Selection.ShapeRange.Line.Weight = 0.75
    Selection.ShapeRange.Line.DashStyle = msoLineSolid
    Selection.ShapeRange.Line.Style = msoLineSingle
    Selection.ShapeRange.Line.Transparency = 0#
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.ForeColor.RGB = RGB(0, 0, 0)
    Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = 53.5
    Selection.ShapeRange.Width = 215.3
    Selection.ShapeRange.Left = 99.35
    Selection.ShapeRange.Top = 28.8
    Selection.ShapeRange.TextFrame.MarginLeft = 7.2
    Selection.ShapeRange.TextFrame.MarginRight = 7.2
    Selection.ShapeRange.TextFrame.MarginTop = 1.44
    Selection.ShapeRange.TextFrame.MarginBottom = 1.44
    Selection.ShapeRange.RelativeHorizontalPosition = _
        wdRelativeHorizontalPositionColumn
    Selection.ShapeRange.RelativeVerticalPosition = _
        wdRelativeVerticalPositionParagraph
    Selection.ShapeRange.Left = InchesToPoints(0.13)
    Selection.ShapeRange.Top = InchesToPoints(-0.1)
    Selection.ShapeRange.LockAnchor = False
    Selection.ShapeRange.LayoutInCell = True
    Selection.ShapeRange.WrapFormat.AllowOverlap = True
    Selection.ShapeRange.WrapFormat.Side = wdWrapBoth
    Selection.ShapeRange.WrapFormat.DistanceTop = InchesToPoints(0)
    Selection.ShapeRange.WrapFormat.DistanceBottom = InchesToPoints(0)
    Selection.ShapeRange.WrapFormat.DistanceLeft = InchesToPoints(0.13)
    Selection.ShapeRange.WrapFormat.DistanceRight = InchesToPoints(0.13)
    Selection.ShapeRange.WrapFormat.Type = 3
    Selection.ShapeRange.ZOrder 4
    Selection.ShapeRange.TextFrame.AutoSize = False
    Selection.ShapeRange.TextFrame.WordWrap = True
    Selection.ShapeRange.TextFrame.TextRange.ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
    Selection.ShapeRange.TextFrame.TextRange.ParagraphFormat.SpaceAfter = 0
 
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
 
 
 
Application.ScreenUpdating = True
 
 
 
ActiveDocument.UndoClear
 
Selection.Find.ClearFormatting
Call ClearFindAndReplaceParameters
 
Exit Sub
Out3:
 

End Sub

---

Quote:

---

Originally Posted by freed59

I couldn't get it to run

---

Getting it to 'run' is trivial - simply add it to a VBA module then click anywhere in it and press F5 - or run it from the GUI the same as might do for most macros.

Quote:

---

Originally Posted by macropod

Getting it to 'run' is trivial - simply add it to a VBA module then click anywhere in it and press F5 - or run it from the GUI the same as might do for most macros.

---

Understood, but it doesn't compile - I made some changes to get it to compile, but it nothing happens when run.

It's OK - I'll figure something out . . .

Thanks for your help.

I tested the code before posting it and it compiled and ran just fine... Your changes - whatever they were - are unlikely to have made it more likely to do either.

As for your own code, I don't have the time to pore over the 700+ lines you posted.

What I can say, though, is that it's extremely inefficient, with loads of Select and Selection references, view switching, and so on, none of which is necessary.

Some of the code also seems quite redundant. For example, having used Find/Replace to convert plain quotes to smart quotes, you then test for unmatched plain quotes. Both of those tests, by the way, have been taken from code I've posted elsewhere (e.g. https://www.msofficeforums.com/104926-post4.html)...