Do until Loop not ending

I am trying to write a macro at work that separates a list of part numbers with semi-colons and in groups of 22. I wrote 2 separate macros, 1 for each process and it works fine. Then I decided to combine them and and have the second half loop until the end of the document. The issue I'm having is that the loop never ends, it just keeps adding a line in between the groups of 22. Here is an example of what the beginning document looks like.

Part No
16516541
1651764
65174651
61567867
56419874
16541674
... and so on

The list always starts with "Part No" and then the list of numbers could be as short as 10 or as long as 2000. The finished document needs to have groups like this:

Part No;654981;6541687;54867;6354357;354863754;... and so on until there is 22 numbers then a new line then the next group of 22, until all of the part numbers are are separated into groups. Here is the code I have so far.

Sub Macro1()
    With ActiveDocument.Bookmarks
        .Add Range:=Selection.Range, Name:="Done"
        .DefaultSorting = wdSortByName
        .ShowHidden = False
    End With
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^p"
        .Replacement.Text = ";"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Do Until ActiveDocument.Bookmarks("\Sel").Range.End = _
ActiveDocument.Bookmarks("Done").Range.End
    With Selection.Find
        .Text = ";*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.TypeParagraph
    Loop
    
    MsgBox ("You have reached the end of the document")
    
End Sub

Moderators Note: Please follow Forum Rule #3 and use code tags. Added this time, but please use them in the future…Thanks.