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. Anonymous
    2021-05-24T04:52:45+00:00

    So I won't mistakenly take the wrong version, can you please copy it to the latest post?

    Also, does it now deliver as well the eighth line of each "record" and place a blank line between "records"? I may have the wrong version even after screen refresh as the results are still displaying seven lines each "record"...

    Was this answer helpful?

    0 comments
  2. Paul Edstein 82,871 Reputation points Volunteer Moderator
    2021-05-24T04:36:18+00:00

    In that case, please mark the post with the 2nd macro - which I've updated to incorporate all the changes - as the Answer.

    Was this answer helpful?

    0 comments