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

Paul Edstein 82,871 Reputation points Volunteer Moderator

2021-05-24T03:06:55+00:00

To pick up the categories that have nothing after the category type (as well as those that do), you could change:

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

to:

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

To output unformatted text (which should maintain the colour of whatever you're exporting to), change:

DocTgt.Characters.Last.FormattedText = .FormattedText

to:

DocTgt.Characters.Last.Text = .Text
Was this answer helpful?

0 comments No comments
Anonymous

2021-05-24T03:27:39+00:00

The line

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

is causing a syntax error...
Was this answer helpful?

0 comments No comments