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

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

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.

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