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.

UPDATE:
Here is a new code I used and it works. I just need to add in a second line in between the groups and I will be done.

Sub Macro1()
'
' Macro1 Macro
'
'
    Selection.HomeKey Unit:=wdStory
    Dim LineCount As Integer
    LineCount = ActiveDocument.ComputeStatistics(wdStatisticLines)
    Dim GroupCount As Integer
    GroupCount = Int(LineCount / 22)
    Selection.MoveDown Unit:=wdLine, Count:=1
    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
    Dim LoopCount
    For LoopCount = 1 To GroupCount
        With Selection.Find
        .Text = ";*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;"
        .Replacement.Text = "^p^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
    Next LoopCount
    
End Sub

Nevermind no issues now. Here is the final code.

Sub Macro1()
'
' Macro1 Macro
'
'
    Selection.HomeKey Unit:=wdStory
    Dim LineCount As Integer
    LineCount = ActiveDocument.ComputeStatistics(wdStatisticLines)
    Dim GroupCount As Integer
    GroupCount = Int(LineCount / 22)
    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
    Dim LoopCount
    For LoopCount = 1 To GroupCount
        With Selection.Find
        .Text = ";*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;"
        .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
    Selection.TypeParagraph
    Next LoopCount
    
End Sub

Much more efficient (and simpler):

Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range.Duplicate.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[^13]{1,}"
    .Replacement.Text = ";"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = True
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute Replace:=wdReplaceAll
    .Wrap = wdFindStop
    .Text = "*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;"
    .Replacement.Text = "^&^p^p"
    .Execute Replace:=wdReplaceAll
End With
Application.ScreenUpdating = True
End Sub

Before posting, I tested it on a document with 10,000 P/Ns and it ran fine, taking much less time than your's took for the same job.