How can I add to this macro so that it "loops" and continues until reaching the bottom of the source file?

Anonymous

I use the following "recorded" macro regularly to gather information from a SOURCE file to be written to TARGET file. It works well, but I have to invoke the macro via the keyboard some 80 to 100 times each search session. Then, if it's given me less than that many results, I'll search for the first result in its second iteration and erase any duplicate and the rest thereafter, leaving only unique results.

====================

Sub 12345()

' Macro16 Macro

Selection.Find.ClearFormatting 

Selection.Find.Replacement.ClearFormatting 

With Selection.Find 

    .Text = "CATEGORY : FLAVORS" 

    .Replacement.Text = "" 

    .Forward = True 

    .Wrap = wdFindContinue 

    .Format = False 

    .MatchCase = False 

    .MatchWholeWord = False 

    .MatchWildcards = False 

    .MatchSoundsLike = False 

    .MatchAllWordForms = False 

End With 

Selection.Find.Execute 

Selection.MoveUp Unit:=wdLine, Count:=2 

Selection.MoveDown Unit:=wdLine, Count:=8, Extend:=wdExtend 

Selection.Copy 

Windows("TARGET FILE").Activate 

Selection.PasteAndFormat (wdFormatPlainText) 

Selection.TypeParagraph 

Selection.TypeParagraph 

Windows("SOURCE FILE").Activate 

Selection.MoveDown Unit:=wdLine, Count:=2 

End Sub

====================

Is there a statement I can add to the bottom of the macro that will keep repeating what it is that I do (invoking the macro) until it hits the bottom of the SOURCE text file, finding no more, and then stops?

Many thanks to all.

Locked Question. This question was migrated from the Microsoft Support Community. You can vote on whether it's helpful, but you can't add comments or replies or follow the question.

0 comments

Answer accepted by question author

Paul Edstein 82,871 Volunteer Moderator

You seem determined to keep the name of the output file a secret. Assuming it's 'TARGET FILE', try:

Sub Demo()

Application.ScreenUpdating = False

Dim strFnd As String, DocSrc As Document, DocTgt As Document, i As Long

Const StrTgt As String = "TARGET FILE"

strFnd = Trim(UCase(InputBox("Category to Find?")))

If strFnd = "" Then Exit Sub

Set DocSrc = ActiveDocument

For i = 1 To Documents.Count

If Split(Documents(i).Name, ".doc")(0) = StrTgt Then

Set DocTgt = Documents(i): Exit For

End If

If DocTgt Is Nothing Then

MsgBox StrTgt & " is not open", vbInformation

Set DocSrc = Nothing: Exit Sub

End If

If DocTgt.Name = DocSrc.Name Then

MsgBox StrTgt & " is the same as the source document!", vbExclamation

Set DocSrc = Nothing: Set DocTgt = Nothing: Exit Sub

End If

With DocSrc.Range

With .Find

.ClearFormatting 

.Replacement.ClearFormatting 

.Text = "[!^13]@^13[!^13]@^13CATEGORY : \*^13\*^13\*^13\*^13\*^13\*^13" 

.Replacement.Text = "" 

.Forward = True 

.Wrap = wdFindStop 

.Format = False 

.MatchWildcards = True 

.Execute

End With

Do While .Find.Found

If UCase(Trim(Split(Split(Split(.Text, "CATEGORY : ")(1), vbCr)(0), " ")(0))) = strFnd Then 

  DocTgt.Characters.Last.Text = .Text & vbCr

End If 

.Collapse wdCollapseEnd

.Find.Execute

Loop

End With

Set DocSrc = Nothing: Set DocTgt = Nothing

Application.ScreenUpdating = True

End Sub

0 comments

Answer accepted by question author

Paul Edstein 82,871 Volunteer Moderator

There seems to be some serious scope creep going on here...

To do that, you could insert:

For i = 0 To UBound(Split(strFnd, ","))

before:

Select Case strFnd

which you'd also change to:

Select Case Split(strFnd, ",")(i)

Additionally, change:

If UCase(Trim(Split(Split(Split(.Text, "CATEGORY : ")(1), vbCr)(0), " ")(0))) = strFnd Then

to:

If UCase(Trim(Split(Split(Split(.Text, "CATEGORY : ")(1), vbCr)(0), " ")(0))) = Split(strFnd, ",")(i) Then

and insert:

before:

Set DocSrc = Nothing: Set DocTgt = Nothing

If you have a standard set of terms to search for, then irrespective of whether all might be present in a given document, you could replace:

strFnd = Trim(UCase(InputBox("Category to Find?")))

If strFnd = "" Then Exit Sub

with something like:

strFnd = "STRAWBERRIES,BLUEBERRIES,LIMES,MANGOS"

doing away with the input box and the risk on input errors.

0 comments

Answer accepted by question author

Paul Edstein 82,871 Volunteer Moderator

You really need to be clearer about your requirements.

Change:

Dim strFnd As String, DocSrc As Document, DocTgt As Document, i As Long

to:

Dim strFnd As String, DocSrc As Document, DocTgt As Document, i As Long, Clr As Long

before:

With DocSrc.Range

Insert:

Select Case strFnd

Case "BLUEBERRIES": Clr = "&H6B5CA4"

Case "LIMES": Clr = "&H00FF00"

Case "POMEGRANATES": Clr = "&H38F40C"

Case "STRAWBERRIES": Clr = "&HEA1625"

End Select

before:

DocTgt.Characters.Last.Text = .Text & vbCr

insert:

DocTgt.Characters.Last.Font.Color = Clr

0 comments

47 additional answers

Anonymous

2021-05-23T06:07:06+00:00

Not working, but let me spell out what I recorded for the macro to accomplish:

First, SOURCE FILE and TARGET FILE are both open when I begin and they need to stay open, as I will be doing some eight search categories for copying to TARGET FILE.

Here is a sample of what it finds when searching for "CATEGORY : STRAWBERRY" from top to bottom of the text file:

21009099987876 INTERNATIONAL TRANSFER CORP.

BLAH, BLAH, BLAH, BLAH, BLAH, BLAH, BLAH, BLAH,

CATEGORY : STRAWBERRY BLAH, BLAH, BLAH, BLAH

BLAH, BLAH, BLAH, BLAH, BLAH, BLAH, BLAH, BLAH,

TERRITORY: EQUATORIAL NEW NORTH ISLANDS

EURO DIVISION

16 MAIN STREET

BATHURST, RI 27235

It finds "CATEGORY : STRAWBERRY" (ALWAYS on the left of the third line). Now, it goes up two lines (top left of first line), highlights all eight lines downward (ALL are eight-liners), copies the eight lines to the bottom of the target file, hits a return for a blank line and stops. I invoke the macro again and it does the same with the next one (actually, I hit it some 50 to 100 times while watching it catch up with me).

I'd like to add to this macro only (leaving the rest precisely as is) what will have the macro repeat itself (loop?) until it reaches the bottom of the source file and stops. Nothing else, as this is old and simple but most reliable.

Is this possible?

Many thanks.
Was this answer helpful?

0 comments No comments
Paul Edstein 82,871 Reputation points Volunteer Moderator

2021-05-23T05:33:25+00:00
Without knowing something about the structure of your source document and what all your Selection.MoveUp & Selection.MoveDown code is selecting, it's impossible to provide the requisite code. The following will get you started:

Sub Demo()

Application.ScreenUpdating = False

Dim strFnd As String, DocSrc As Document, DocTgt As Document

Set DocSrc = ActiveDocument: Set DocTgt = Documents.Add

With DocSrc.Range

With .Find
```
.ClearFormatting 

.Replacement.ClearFormatting 

.Text = "^13\*CATEGORY : FLAVORS\*^13" 

.Replacement.Text = "" 

.Forward = True 

.Wrap = wdFindStop 

.Format = False 

.MatchWildcards = True 

.Execute 
```
End With

Do While .Find.Found
```
DocTgt.Characters.Last.FormattedText = .FormattedText 

.Collapse wdCollapseEnd 

.Find.Execute 
```
Loop

End With

Application.ScreenUpdating = True

End Sub

The above code looks for your 'CATEGORY : FLAVORS' string in the active document and creates a new document containing all instances of that, plus some surrounding content.
Was this answer helpful?

0 comments No comments