#1
|
|||
|
|||
Do Loop Breaking Up.
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 |
#2
|
||||
|
||||
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
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#3
|
|||
|
|||
Do Loop
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!! |
#4
|
||||
|
||||
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
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#5
|
|||
|
|||
This worked, really appreciate all your help, now i don't have to keep holding the macro key.
Thanks a lot!! |
#6
|
||||
|
||||
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.
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#7
|
|||
|
|||
Previous macro
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 |