Do Loop Breaking Up.

donlincolnmsof · #1 12-02-2021, 12:40 PM

Hello

I have the macro below, which opens 3 Windows.

1st window contains all the data that needs to be extracted.
2nd window is for when it cuts out a block of data from 1st window and places in 2nd window for further processing.
3rd window is used to process multiple instances of data that was found in 2nd window and keep taking that out until no more data is found and then from the 2nd window it goes back to 1st window and picks up the next block of data.

Macro works fine its does all as above, but when the macro key is press its only takes out 1 record and then breaks and then I have to keep pressing the key over and over again to make it work.

Is there is a way to put a loop on the top of the macro and end it by the end sub for the macro to run continuously until all Is processed.

Any help will be greatly appreciated.

Thanks.

Sub Macro4()
'
' Macro4 Macro
' Macro recorded 11/26/2021 by don
'
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
With Selection.Find
.Text = "<!doctype html>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False

.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Extend
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Find.ClearFormatting
With Selection.Find
.Text = "</html>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Cut

'2nd window

Windows(2).Activate
Selection.WholeStory
Selection.Paste

'1st do

Do

Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
With Selection.Find
.Text = "^#^#^#-^#^#^#-^#^#^#^#"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute

If Selection.Find.Found = True Then

Selection.Copy

'3rd window

Windows(3).Activate
Selection.Paste
Selection.TypeText Text:=vbTab
Windows(2).Activate
Selection.Delete Unit:=wdCharacter, Count:=1

Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
With Selection.Find
.Text = "<title>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Extend
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Find.ClearFormatting
With Selection.Find
.Text = "</title>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Copy
Windows(3).Activate
Selection.Paste
Selection.TypeParagraph
Windows(2).Activate

End If

Loop Until Selection.Find.Found = False

'2nd do

Do

Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
With Selection.Find
.Text = "(^#^#^#) ^#^#^#-^#^#^#^#"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute

If Selection.Find.Found = True Then

Selection.Copy

'3rd window

Windows(3).Activate
Selection.Paste
Selection.TypeText Text:=vbTab
Windows(2).Activate
Selection.Delete Unit:=wdCharacter, Count:=1

Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
With Selection.Find
.Text = "<title>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Extend
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Find.ClearFormatting
With Selection.Find
.Text = "</title>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Copy
Windows(3).Activate
Selection.Paste
Selection.TypeParagraph
Windows(2).Activate

End If

Loop Until Selection.Find.Found = False

'3rd do

Do

Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
With Selection.Find
.Text = "(^#^#^#)^#^#^#-^#^#^#^#"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute

If Selection.Find.Found = True Then

Selection.Copy

'3rd window

Windows(3).Activate
Selection.Paste
Selection.TypeText Text:=vbTab
Windows(2).Activate
Selection.Delete Unit:=wdCharacter, Count:=1

Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
With Selection.Find
.Text = "<title>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Extend
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Find.ClearFormatting
With Selection.Find
.Text = "</title>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Copy
Windows(3).Activate
Selection.Paste
Selection.TypeParagraph
Windows(2).Activate

End If

Loop Until Selection.Find.Found = False

'1st window

Windows(1).Activate

End Sub

Guessed · #2 12-02-2021, 04:30 PM

This is not particularly clean code but it appears that there are far better ways to achieve what you are trying to do. Using selection while jumping across multiple documents is a very bad idea if you want to know where you are.

Your code implies that within each <html> element is only one number string and one <title> element. If that is the case then there is no reason to bother with the html elements at all since the pairs of title/number probably match.

Perhaps if you post a sample document we can provide better code to achieve your aims. For instance, the initial loop to find the <html> is better done with ranges along these lines

Code:

  Dim aRng As Range, aDoc As Document, aDoc2 As Document
  
  Set aDoc = ActiveDocument
  Set aRng = aDoc.Range
  With aRng.Find
    .ClearFormatting
    .Text = "\<\!doctype html\>*\</html\>"
    .Forward = True
    .Wrap = wdFindStop
    .MatchCase = False
    .MatchWildcards = True
    Do While .Execute = True
      Set aDoc2 = Documents.Add
      aDoc2.Range.FormattedText = aRng.FormattedText
      'do your inner processing of the <html> element here
    
      aRng.Collapse Direction:=wdCollapseEnd
    Loop
  End With

But I'm not really convinced that there needs to be three documents at all. You should only need the initial document and let the code create an output document for the data you want to gather.

donlincolnmsof · #3 12-02-2021, 09:14 PM

Hello

Thanks for replying. The macro can be real simple if there is number just appear 1 time in the whole beginning and ending of html tag. There are more than 1 numbers in the body of beginning and ending of the html tag, so the whatever is in title and /title has to be attached to those number to know as to which number belong to which records. Attached is the output file.

input file can be found below link it only 3 records but 48 pages of html data in word.

input data 1202.doc - Google Docs

also one of the things that complicates the macro, that sometime numbers have 3 format to extract as below.

(###) ###-####
(###)###-####
###-###-####

As you said there is a better way to do it, if it can be done without opening 3 windows that would be great.

Thanks a lot!!

Guessed · #4 12-05-2021, 03:13 PM

Try this code on your document

Code:

Sub GetPhone()
  Dim aRng As Range, aDoc As Document, aDoc2 As Document
  Dim aRngInner As Range, sText As String, sTitle As String
  
  Set aDoc = ActiveDocument
  Set aRng = aDoc.Range
  With aRng.Find
    .ClearFormatting
    .Text = "\<\!doctype html\>*\</html\>"
    .Forward = True
    .Wrap = wdFindStop
    .MatchCase = False
    .MatchWildcards = True
    Do While .Execute = True
      'Use this range to find the first title instance inside it
      Set aRngInner = aRng.Duplicate
      With aRngInner.Find
        .Text = "\<title\>*\</title\>"
        .Forward = True
        .Wrap = wdFindStop
        .MatchCase = False
        .MatchWildcards = True
        If .Execute = True Then
          sTitle = aRngInner.Text
        Else
          sTitle = "Title Not Found"
        End If
      End With
      'Now use the same range to find all the phone numbers
      Set aRngInner = aRng.Duplicate
      With aRngInner.Find
        .Text = "[0-9]{3}[\) -]{1,2}[0-9]{3}-[0-9]{4}"
        .Forward = True
        .Wrap = wdFindStop
        .MatchCase = False
        .MatchWildcards = True
        Do While .Execute = True
          Debug.Print aRngInner.Text, sTitle
          sText = sText & vbCr & aRngInner.Text & vbTab & sTitle
          aRngInner.Collapse Direction:=wdCollapseEnd
          aRngInner.End = aRng.End
        Loop
      End With
      aRng.Collapse Direction:=wdCollapseEnd
      If Len(sText) > 0 Then sText = sText & vbCr
    Loop
  End With
  If Len(sText) > 0 Then
    Set aDoc2 = Documents.Add(Visible:=True)
    aDoc2.Range.Text = sText
  Else
    MsgBox "No hits"
  End If
End Sub

donlincolnmsof · #5 12-06-2021, 11:03 AM

This worked, really appreciate all your help, now i don't have to keep holding the macro key.

Thanks a lot!!

Guessed · #6 12-06-2021, 02:02 PM

Good to hear it works for you.

It wouldn't have been possible to create the code correctly without your pre and post document samples but now it is done you should go back and remove those links IF it is real information. We shouldn't keep personally identifiable information on public forums.

donlincolnmsof · #7 12-29-2021, 02:52 PM

Hello Andrew

I posted another macro which is very similar to the one that i posted earlier, i was wondering if you can tweak it to make it work. below is the link to that macro.

Thanks.

https://www.msofficeforums.com/word-...tml#post164715

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Getting rid of Non-breaking space	WJSwanepoel	Word VBA	3	03-30-2021 11:35 PM
non-breaking ] and [	nielsgeode	Word	13	08-18-2017 11:48 PM
Equation non-breaking	mohsen.amiri	Word	2	02-04-2017 12:03 AM
Breaking up a mergefield into parts	WillTRiker	Mail Merge	1	07-10-2015 01:58 AM
Non-breaking items	judicial85	Word	7	02-23-2012 07:12 PM