Loops that stop working after a while (VBA for Word)

[OlgaFal]

Hi everybody,

I should start apologizing if my question is too stupid, I am a legal editor and have been self-learning VBA to let machines do my work basically. I have been struggling with this code to run several wildcard searches and copy whatever is found in a new document. When I debug the code works perfectly, but if I run it, it stops halfway in the second loop in Find.execute. I would be eternally grateful if anyone can have a look at it. Most of my macros follow this principle of finding something and copying into a new document, so fixing this would make such a big difference for me:

'Creates a new document with a list of all the disputes cited in the footnotes

Dim rngsource As Range
If ActiveDocument.Footnotes.Count > 0 Then
Set rngsource = ActiveDocument.Footnotes(1).Range
rngsource.WholeStory
End If

Dim strSource As String
Dim strDestination As String

strSource = ActiveWindow.Caption
Documents.Add
strDestination = ActiveWindow.Caption

Dim rngdestination As Range
Set rngdestination = Windows(strDestination).Selection.Range
rngdestination.WholeStory

Windows(strSource).Activate

rngsource.Select

' this is my first loop, once selected the source document. this one works fine and ends when is done

Selection.Find.ClearFormatting
Selection.Find.Text = "Panel Report,[!^013]@[;,]"
Selection.Find.MatchWildcards = True
Selection.Find.Execute
Do While Selection.Find.Found

Selection.Copy

Selection.MoveRight Unit:=wdCharacter, _
Count:=1, Extend:=wdMove

Windows(strDestination).Activate
Selection.EndKey Unit:=wdStory
Selection.Paste
Selection.TypeParagraph

Windows(strSource).Activate
Selection.Find.Execute
Loop

' second loop. It works for a while and then stops halfway
Windows(strSource).Activate

rngsource.Select


Selection.Find.ClearFormatting
Selection.Find.Text = "Appellate[^032^s]Body Report,[!^013]@[;,]"
Selection.Find.MatchWildcards = True
Selection.Find.Execute
Do While Selection.Find.Found

Selection.Copy

Selection.MoveRight Unit:=wdCharacter, _
Count:=1, Extend:=wdMove

Windows(strDestination).Activate
Selection.EndKey Unit:=wdStory
Selection.Paste
Selection.TypeParagraph

Windows(strSource).Activate
Selection.Find.Execute
Loop

Windows(strSource).Activate
' third loop. I only get this far when I debug
rngsource.Select


Selection.Find.ClearFormatting
Selection.Find.Text = "Panel Reports,[!^013]@[.:]^013"
Selection.Find.MatchWildcards = True
Selection.Find.Execute
Do While Selection.Find.Found

Selection.Copy

Selection.MoveRight Unit:=wdCharacter, _
Count:=1, Extend:=wdMove

Windows(strDestination).Activate
Selection.EndKey Unit:=wdStory
Selection.Paste
Selection.TypeParagraph

Windows(strSource).Activate
Selection.Find.Execute
Loop


Windows(strSource).Activate

rngsource.Select


Selection.Find.ClearFormatting
Selection.Find.Text = "Appellate[^032^s]Body Reports,[!^013]@[.:]^013"
Selection.Find.MatchWildcards = True
Selection.Find.Execute
Do While Selection.Find.Found

Selection.Copy

Selection.MoveRight Unit:=wdCharacter, _
Count:=1, Extend:=wdMove

Windows(strDestination).Activate
Selection.EndKey Unit:=wdStory
Selection.Paste
Selection.TypeParagraph

Windows(strSource).Activate
Selection.Find.Execute
Loop



Windows(strSource).Activate

rngsource.Select


Selection.Find.ClearFormatting
Selection.Find.Text = "Panel Reports,[!^013]@[.:]^032^013"
Selection.Find.MatchWildcards = True
Selection.Find.Execute
Do While Selection.Find.Found

Selection.Copy

Selection.MoveRight Unit:=wdCharacter, _
Count:=1, Extend:=wdMove

Windows(strDestination).Activate
Selection.EndKey Unit:=wdStory
Selection.Paste
Selection.TypeParagraph

Windows(strSource).Activate
Selection.Find.Execute
Loop

Windows(strSource).Activate

rngsource.Select


Selection.Find.ClearFormatting
Selection.Find.Text = "Appellate[^032^s]Body Reports,[!^013]@[.:]^032^013"
Selection.Find.MatchWildcards = True
Selection.Find.Execute
Do While Selection.Find.Found

Selection.Copy

Selection.MoveRight Unit:=wdCharacter, _
Count:=1, Extend:=wdMove

Windows(strDestination).Activate
Selection.EndKey Unit:=wdStory
Selection.Paste
Selection.TypeParagraph

Windows(strSource).Activate
Selection.Find.Execute
Loop


End Sub

Thanks so so much!!

 

[macropod]

Perhaps:

Sub Demo()
Application.ScreenUpdating = False
Dim DocSrc As Document, RngSrc As Range
Dim DocTgt As Document, RngTgt As Range
Set DocSrc = ActiveDocument
With DocSrc
  If .Footnotes.Count = 0 Then Exit Sub
  Set DocTgt = Documents.Add
  Set RngSrc = .StoryRanges(wdFootnotesStory)
  With RngSrc.Duplicate
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Replacement.Text = ""
      .Text = "Panel Report,[!^13]@[;,]"
      .MatchWildcards = True
    End With
    Do While .Find.Execute
      With DocTgt.Range
        .InsertAfter vbCr
        Set RngTgt = .Characters.Last
      End With
      RngTgt.FormattedText = .FormattedText
    Loop
  End With
  With RngSrc.Duplicate
    With .Find
      .Text = "Appellate[ ^s]Body Report,[!^13]@[;,]"
      .MatchWildcards = True
    End With
    Do While .Find.Execute
      With DocTgt.Range
        .InsertAfter vbCr
        Set RngTgt = .Characters.Last
      End With
      RngTgt.FormattedText = .FormattedText
    Loop
  End With
  With RngSrc.Duplicate
    With .Find
      .Text = "Panel Reports,[!^13]@[.:]^13"
      .MatchWildcards = True
    End With
    Do While .Find.Execute
      With DocTgt.Range
        .InsertAfter vbCr
        Set RngTgt = .Characters.Last
      End With
      RngTgt.FormattedText = .FormattedText
    Loop
  End With
  With RngSrc.Duplicate
    With .Find
      .Text = "Appellate[ ^s]Body Reports,[!^13]@[.:]^13"
      .MatchWildcards = True
    End With
    Do While .Find.Execute
      With DocTgt.Range
        .InsertAfter vbCr
        Set RngTgt = .Characters.Last
      End With
      RngTgt.FormattedText = .FormattedText
    Loop
  End With
  With RngSrc.Duplicate
    With .Find
      .Text = "Panel Reports,[!^13]@[.:] ^13"
      .MatchWildcards = True
    End With
    Do While .Find.Execute
      With DocTgt.Range
        .InsertAfter vbCr
        Set RngTgt = .Characters.Last
      End With
      RngTgt.FormattedText = .FormattedText
    Loop
  End With
  With RngSrc.Duplicate
    With .Find
      .Text = "Appellate[ ^s]Body Reports,[!^13]@[.:] ^13"
      .MatchWildcards = True
    End With
    Do While .Find.Execute
      With DocTgt.Range
        .InsertAfter vbCr
        Set RngTgt = .Characters.Last
      End With
      RngTgt.FormattedText = .FormattedText
    Loop
  End With
End With
Application.ScreenUpdating = True
End Sub

Note the lack of selections, window activations, copying & pasting, none of which is necessary.

Cheers
Paul Edstein
[MS MVP - Word]

 

[OlgaFal]

Hi Paul.
This is such a great early Christmas gift! the code works beautifully and much faster than my previous attempt. I will try to learn from it and use a similar approach for the rest of my macro searches. Thanks so so much.

 

[macropod]

Here's a compact version to chew on:

Sub Demo()
Application.ScreenUpdating = False
Dim DocSrc As Document, RngSrc As Range
Dim DocTgt As Document, RngTgt As Range, i As Long
Const StrFnd As String = "Panel Report,[!^13]@[;,]|Appellate[ ^s]Body Report,[!^13]@[;,]|Panel Reports,[!^13]@[.:]^13" & _
  "|Appellate[ ^s]Body Reports,[!^13]@[.:]^13|Panel Reports,[!^13]@[.:] ^13|Appellate[ ^s]Body Reports,[!^13]@[.:] ^13"
Set DocSrc = ActiveDocument
With DocSrc
  If .Footnotes.Count = 0 Then Exit Sub
  Set DocTgt = Documents.Add
  Set RngSrc = .StoryRanges(wdFootnotesStory)
  For i = 0 To UBound(Split(StrFnd, "|"))
    With RngSrc.Duplicate
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Replacement.Text = ""
        .Text = Split(StrFnd, "|")(i)
        .MatchWildcards = True
      End With
      Do While .Find.Execute
        With DocTgt.Range
          .InsertAfter vbCr
          Set RngTgt = .Characters.Last
        End With
        RngTgt.FormattedText = .FormattedText
      Loop
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub

Cheers
Paul Edstein
[MS MVP - Word]

 

[OlgaFal]

Hi again,

Thanks so much for the simplified version! I am trying to use it for another macro that needs to search on the main document, not the footnotes. I just changed the wildcard search and the story, but it does not seem to work:

Dim DocSrc As Document, RngSrc As Range
Dim DocTgt As Document, RngTgt As Range
Set DocSrc = ActiveDocument
With DocSrc
Set DocTgt = Documents.Add
Set RngSrc = .StoryRanges(wdMainTextStory)

I am really grateful for the help. I have been struggling with this for weeks, I have still so much to learn!

 

[macropod]

Using the compact version for the code for a single Find expression would be overkill; if you're using it for multiple Find expressions, each must be separated by a | character.

Aside from the Find expression itself, all you need do with the original macro is delete:
If .Footnotes.Count = 0 Then Exit Sub
plus any:
With RngSrc.Duplicate
...
End With
blocks you don't need
and change:
Set RngSrc = .StoryRanges(wdFootnotesStory)
to:
Set RngSrc = .StoryRanges(wdMainTextStory)
both of which you appear to have done.

You haven't posted any Find expressions, so I can't comment directly on that. Did you confirm your Find expressions work in the Find/Replace dialogue?

Cheers
Paul Edstein
[MS MVP - Word]

 

[OlgaFal]

Thanks! I tried with this one and it does not work. The wildcard searches work, I tried separately:

Sub test

Application.ScreenUpdating = False
Dim DocSrc As Document, RngSrc As Range
Dim DocTgt As Document, RngTgt As Range
Set DocSrc = ActiveDocument
With DocSrc
  Set DocTgt = Documents.Add
  Set RngSrc = .StoryRanges(wdMainTextStory)
  With RngSrc.Duplicate
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Replacement.Text = ""
      .Text = "(""[!^032][!^013]@[!^032]""[!^013]@^02)"
      .MatchWildcards = True
    End With
    Do While .Find.Execute
      With DocTgt.Range
        .InsertAfter vbCr
        Set RngTgt = .Characters.Last
      End With
      RngTgt.FormattedText = .FormattedText
    Loop
  End With
  With RngSrc.Duplicate
    With .Find
      .Text = "(""[!^032][!^013]@[!^032]""^02)"
      .MatchWildcards = True
    End With
    Do While .Find.Execute
      With DocTgt.Range
        .InsertAfter vbCr
        Set RngTgt = .Characters.Last
      End With
      RngTgt.FormattedText = .FormattedText
    Loop
  End With
  With RngSrc.Duplicate
    With .Find
      .Text = "(""[!^032][!^013]@[!^032]"")"
      .MatchWildcards = True
    End With
    Do While .Find.Execute
      With DocTgt.Range
        .InsertAfter vbCr
        Set RngTgt = .Characters.Last
      End With
      RngTgt.FormattedText = .FormattedText
    Loop
  End With
End With
DocTgt.Activate
Dim rng As Range
Set rng = ActiveDocument.Content
With rng.Find
.ClearFormatting
.Font.Italic = True
 While .Execute
rng.HighlightColorIndex = wdYellow
rng.Collapse wdCollapseEnd
        Wend
    End With


Application.ScreenUpdating = True

End Sub

 

[macropod]

Perhaps you could clarify what you're trying to find. Your:
• 1st Find expression appears to be looking for "[! ][!^13]@[! ]"[!^13]@^02 - which translates to a plain quote, followed by anything other than a space, followed by anything other than one or more paragraph breaks, followed by anything other than a space, followed by a plain quote, followed by anything other than one or more paragraph breaks, followed by ASCII 2.
• 2nd Find expression appears to be looking for "[! ][!^13]@[! ]"^02 - which translates to a plain quote, followed by anything other than a space, followed by anything other than one or more paragraph breaks, followed by anything other than a space, followed by a plain quote, followed by ASCII 2.
• 3rd Find expression appears to be looking for "[! ][!^13]@[! ]"^02 - which translates to a plain quote, followed by anything other than a space, followed by anything other than one or more paragraph breaks, followed by anything other than a space, followed by a plain quote.

The () characters in your Find expressions don't contribute anything meaningful in this context and there is no need to specify ordinary spaces by their ASCII value (^32 or ^032). Likewise, you don't need to use ^013 - ^13 will suffice.

Cheers
Paul Edstein
[MS MVP - Word]

 

[OlgaFal]

Thanks Paul,

I want to create a separate document with all the quotes of the text accompanied by their footnotes; and in this new document I want to highlight all the italics so that I can check whether in the footnote reference to the quote the information on emphasis has been added (the editor's life, what can I say). So yes, the wildcards locate all the quotes and their footnotes (that part works fine, as I have done it manually many times). But the loop to copy whatever found in a new document does not work. I just do not get why the same code worked well for the other macro that only differed in the wildcard search and the range. But as I said, a dismayed newbie here.

Many thanks,

Olga

 

[macropod]

Try:

Sub Demo()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document, RngTgt As Range
Set DocSrc = ActiveDocument: Set DocTgt = Documents.Add
With DocSrc
  With .Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Replacement.Text = ""
      .Text = "[""“][!""“^13]@[""”]"
      .MatchWildcards = True
    End With
    Do While .Find.Execute
      If .Characters.Last.Next.Footnotes.Count = 1 Then
        .End = .End + 1
      End If
      With DocTgt.Range
        .InsertAfter vbCr
        Set RngTgt = .Characters.Last
      End With
      RngTgt.FormattedText = .FormattedText
      .Collapse wdCollapseEnd
    Loop
  End With
End With
Application.ScreenUpdating = True
End Sub

Note the addition of '.Collapse wdCollapseEnd' - I probably should have had that before 'Loop' in the previous macros, too.

Cheers
Paul Edstein
[MS MVP - Word]