Find duplicates and combine them

[NoviceUser]

Hi, I wonder if someone can help please? I have posted this on another forum, but had no replies, so I thought this might be a better place to ask.

I have some code that looks for duplicate lines of text in a word document, and then paste the number of duplicates at the top of the page. E.g, If there are 3 of the same line, it will copy the same line to the top with a "3 x " in front of it. It works perfectly if the line only contains one word, but as soon as there's more than one word, it puts each word down as a new line.

Sample list:
leopard
lion
lion
african elephant
african elephant
african elephant
buffalo

It needs to paste the following into the new word document:
1 x leopard


2 x lion
3 x african elephant
1 x buffalo

At the moment, it is writing the line, 'african elephant' as two separate lines, I.e:
1 x leopard
2 x lion
3 x african
3 x elephant
1 x buffalo

The variable 'r' has the value "african elephant", until it goes past this line in the code:

Do While r.Find.Execute(FindText:="<*>", MatchWildcards:=True, Wrap:=wdFindStop) = True

As soon as I go past this point, 'r' changes to "african", but should be 'african elephant'. I have had some help putting the code together and I've tried a lot of ways to fix it, but I cannot figure out what I'm doing wrong.

Here is the code I'm using:

Sub ArrangeList()
    Dim r As Range

    Set r = ActiveDocument.Range
    If (r.Characters.Last.Text = vbCr) Then r.End = r.End - 1
    SortList r
End Sub
Function SortList(r As Range)
    Dim sWrd As String
    Dim Found As Boolean
    Dim N As Integer, i As Long, j As Integer, k As Integer, WordNum As Integer
    N = r.Words.Count
    ReDim Freq(N) As Integer
    ReDim Words(N) As String
    Dim temp As String

    i = 1
    WordNum = 0
    Do While r.Find.Execute(FindText:="<*>", MatchWildcards:=True, Wrap:=wdFindStop) = True
        If i = N Then Exit Do
            Found = False
           
            For j = 1 To WordNum
                If Words(j) = r.Text Then
                    Freq(j) = Freq(j) + 1
                    Found = True
                    Exit For
                End If
            Next j
            
        If Not Found Then
            WordNum = WordNum + 1
            Words(WordNum) = r.Text
            Freq(WordNum) = 1
        End If
        i = i + 1
    Loop

    r.Collapse wdCollapseStart
    r.Collapse wdCollapseEnd
    r.InsertParagraphBefore
    r.Collapse wdCollapseEnd

    For j = 1 To WordNum
        r.InsertAfter Freq(j) & " x " & Words(j) & vbCr
    Next j
    r.InsertAfter vbCr
    r.InsertAfter vbFormFeed

End Function