Word The below functions as it should however at end of Document it continues.

It looks like the issue is that wdFindStop only controls what happens when Word reaches the end of the search range. In your macro, Selection.Find is repeatedly executed after you return to the beginning of the document using Selection.HomeKey Unit:=wdStory. Because your search uses wdFindContinue, Word wraps around to the beginning and continues processing matches indefinitely.

Try using a Range object for the initial search and allow it to search only forward to the end of the document. Unlike Selection, a Range does not require you to reposition the user's selection, and you can advance its starting position after each match.

If you want to retain your existing structure, you can record the document position before each iteration and exit the loop when you reach the end. For example, replace Do While .Execute with the following pattern, adapting the range and selection operations to your macro:

Dim docEnd As Long

docEnd = ActiveDocument.Content.End

Do While .Execute
    If Selection.Start >= docEnd Then Exit Do

    ' Your existing processing code goes here

Loop

However, this check alone is not sufficient if your code resets the selection to the start of the document on every iteration, as your macro currently does. That reset means the search can find the same matches repeatedly.

The change would be to preserve the position of the initial search and advance beyond each processed match instead of returning to wdStory. You can also set .Wrap = wdFindStop for the initial search, but you must ensure the search resumes after the last processed match rather than from the beginning.

Because your macro switches between Windows(1) and Windows(2) and moves the selection extensively, the fix would be to use a dedicated Range for the initial search while leaving the other window's selection operations intact.

The following version records the end of the original document and uses a Range for the initial search so it does not wrap around and repeat matches. The search position advances after each match, while your existing window-switching and copy/paste operations remain in place.

Sub Test()

    Dim rng As Range
    Dim docEnd As Long
    Dim strText As String

    Selection.Find.ClearFormatting
    Selection.Find.Font.Size = 12

    Selection.MoveRight Unit:=wdCharacter, Count:=1

    Set rng = ActiveDocument.Range(Selection.Start, ActiveDocument.Content.End)
    docEnd = ActiveDocument.Content.End

    With rng.Find
        .Text = "<[A-Z]{1,}>"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With

    Do While rng.Find.Execute

        If rng.Start >= docEnd Then Exit Do

        Selection.SetRange Start:=rng.Start, End:=rng.End
        Selection.Fields.Update

        strText = Selection.Text
        Selection.Collapse Direction:=wdCollapseStart

        Windows(2).Activate

        With Selection.Find
            .ClearFormatting
            .Forward = True
            .Wrap = wdFindStop
            .MatchCase = True
            .MatchWholeWord = True
            .Text = strText
            .MatchWildcards = False
            .Execute
        End With

        Selection.HomeKey Unit:=wdLine
        Selection.Extend
        Selection.EndKey
        Selection.Copy

        Selection.EscapeKey
        Selection.EscapeKey
        Selection.HomeKey Unit:=wdStory

        Windows(1).Activate

        Selection.Find.ClearFormatting
        Selection.Find.Font.Size = 12

        With Selection.Find
            .Text = "<[A-Z]{1,}>"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindStop
            .Format = True
            .MatchCase = False
            .MatchWholeWord = True
            .MatchWildcards = True
        End With

        Selection.Find.Execute
        Selection.MoveDown Unit:=wdLine, Count:=1
        Selection.HomeKey Unit:=wdLine
        Selection.TypeParagraph
        Selection.MoveUp Unit:=wdLine, Count:=1
        Selection.Paste
        Selection.Delete

        ' Advance the original search range beyond the match.
        rng.SetRange Start:=Selection.End, End:=docEnd

        If rng.Start >= docEnd Then Exit Do

        With rng.Find
            .Text = "<[A-Z]{1,}>"
            .Forward = True
            .Wrap = wdFindStop
            .Format = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = True
        End With

    Loop

End Sub

Note that because your macro edits the first document while searching it, the document's end position and the selection position can change during execution. The code above preserves the intended stop-at-end behavior, but the exact range advancement depends on where the paste and delete operations leave the selection. If those operations change the text before the next match, the solution is to track the original match's end position explicitly rather than relying on Selection.End.

If the above response helps answer your question, remember to "Accept Answer" so that others in the community facing similar issues can easily find the solution. Your contribution is highly appreciated.

hth

Marcin