Find duplicates and combine them

NoviceUser · #1 03-03-2023, 05:09 AM

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:

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:

Code:

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

gmayor · #2 03-03-2023, 06:09 AM

Your search string only finds single words, whereas to get what you want you need paragraphs so try

Code:

Do While r.Find.Execute(findText:="<*^13", MatchWildcards:=True, Wrap:=wdFindStop) = True
        r.End = r.End - 1

NoviceUser · #3 03-03-2023, 08:19 AM

Hi Graham, thanks for your help. It works perfectly now....

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
find/remove duplicates	hephalumph	Word	9	02-06-2022 07:23 PM
Find duplicates in colums by row only	akol1214	Excel	3	10-04-2018 11:58 PM
How to find out the duplicates and highlight them?	Learner7	Excel	6	06-08-2017 06:04 AM
find and delete duplicates	rcVBA	Word VBA	4	05-15-2013 03:08 PM
Find duplicates formula	hannu	Excel	2	10-26-2010 02:48 AM