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

Anonymous
2021-05-23T03:07:20+00:00

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.

Microsoft 365 and Office | Word | For home | Windows

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 Reputation points Volunteer Moderator
2021-05-23T21:48:52+00:00

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

Next

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

Was this answer helpful?

2 people found this answer helpful.
0 comments
Answer accepted by question author
Paul Edstein 82,871 Reputation points Volunteer Moderator
2021-05-25T21:42:12+00:00

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:

Next

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.

Was this answer helpful?

1 person found this answer helpful.
0 comments
Answer accepted by question author
Paul Edstein 82,871 Reputation points Volunteer Moderator
2021-05-25T00:40:32+00:00

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

Was this answer helpful?

1 person found this answer helpful.
0 comments

47 additional answers

Sort by: Most helpful
Most helpful Newest Oldest
  1. Paul Edstein 82,871 Reputation points Volunteer Moderator
    2021-05-24T01:28:34+00:00

    I hadn't noticed before but you've changed the data description from that which you originally posted. Originally, you had no content after the category type on that line. Code updated to reflect the change.

    Was this answer helpful?

    0 comments
  2. Anonymous
    2021-05-24T01:20:18+00:00

    I went ahead and repasted the macro code just to be sure and then took the text I earlier pasted, added some from it and this is what I invoked the macro upon, entering "STRAWBERRIES" into the query box:

    210519000122 ONE TWO THREE

    BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    CATEGORY : POMEGRANITES BLAH BLAH BLAH BLAH BLAH BLAH

    DATE: 05/19/2021 BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    THE WORLD PMEGRANITE COMPANY

    46 MAIN STREET

    NEW YOR, NY 10028

    2105190002680 FOUR FIVE SIX

    BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    CATEGORY : STRAWBERRIES BLAH BLAH BLAH BLAH BLAH BLAH

    DATE: 05/19/2021 BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    LEMONS ARE US

    38 SOUR LANE

    NEW YORK, NY 10024

    210519000139 SEVEN EIGHT NINE

    BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    CATEGORY : RAISINS BLAH BLAH BLAH BLAH BLAH BLAH

    DATE: 05/19/2021 BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    RISING RAISINS CORP.

    26 SHRUNKEN BLVD.

    NEW YORK, NY 10029

    210519000122 ONE TWO THREE

    BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    CATEGORY : STRAWBERRIES BLAH BLAH BLAH BLAH BLAH BLAH

    DATE: 05/19/2021 BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    THE WORLD PMEGRANITE COMPANY

    46 MAIN STREET

    NEW YOR, NY 10028

    2105190002680 FOUR FIVE SIX

    BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    CATEGORY : STRAWBERRIES BLAH BLAH BLAH BLAH BLAH BLAH

    DATE: 05/19/2021 BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    LEMONS ARE US

    38 SOUR LANE

    NEW YORK, NY 10024

    210519000139 SEVEN EIGHT NINE

    BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    CATEGORY : RAISINS BLAH BLAH BLAH BLAH BLAH BLAH

    DATE: 05/19/2021 BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    RISING RAISINS CORP.

    26 SHRUNKEN BLVD.

    NEW YORK, NY 10029

    210519000122 ONE TWO THREE

    BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    CATEGORY : STRAWBERRIES BLAH BLAH BLAH BLAH BLAH BLAH

    DATE: 05/19/2021 BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    THE WORLD PMEGRANITE COMPANY

    46 MAIN STREET

    NEW YOR, NY 10028

    2105190002680 FOUR FIVE SIX

    BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    CATEGORY : STRAWBERRIES BLAH BLAH BLAH BLAH BLAH BLAH

    DATE: 05/19/2021 BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    LEMONS ARE US

    38 SOUR LANE

    NEW YORK, NY 10024

    210519000139 SEVEN EIGHT NINE

    BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    CATEGORY : RAISINS BLAH BLAH BLAH BLAH BLAH BLAH

    DATE: 05/19/2021 BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH BLAH

    RISING RAISINS CORP.

    26 SHRUNKEN BLVD.

    NEW YORK, NY 10029

    Their are five iterations of "CATEGORY : STRAWBERRIES" but "Target File" still remains empty...

    Was this answer helpful?

    0 comments