Grouping Cells

[Fox21]

I am trying to group duplicate rows according to Column 3(ID Number). I have used collections as a method, The problem is if there is only two duplicates in column three then only one item shows up in the watch window of the collection.I have posted the result that I want on the right hand side of the excel xl2bb. I am fairly new to vba. I also want to write it out onto the worksheet but has issues.Here is what I have so far:

Sub Duplicate()
Dim coll As New Collection, cls As Class1
Dim arrayDup() As Variant
Dim a As Long, b As Long, rw As Long, cl As Long, s As Long, k As Long

rw = Sheet1.Range("A1").CurrentRegion.Rows.Count
cl = Sheet1.Range("A1").CurrentRegion.Columns.Count
arrayDup = Sheet1.Range("A1").CurrentRegion.Value

For a = 2 To UBound(arrayDup) - 1

For b = a To UBound(arrayDup) - 1

If arrayDup(a, 3) = arrayDup(b + 1, 3) Then

Set cls = New Class1
cls.FullName = arrayDup(b + 1, 1)
cls.LastName = arrayDup(b + 1, 2)
cls.IDNumber = arrayDup(b + 1, 3)

coll.Add cls

End If
Next b
Next a

End Sub

arrange (version 1).xlsb
	A	B	C	D	E	F	G
1	First Name	LastName	IDNumber	>>>>>	First Name	LastName	IDNumber
2	Sea	west	6		Sea	west	6
3	Kicker	east	6		Kicker	east	6
4	Police	north	9		Shia	moody	6
5	Dan	south	3		Dan	south	3
6	Ban	north west	3		Ban	north west	3
7	Shia	moody	6		Police	north	9
8	Kakah	hoodie	10		Kakah	hoodie	10
Sheet1

 

[alansidman]

Can you explain your methodology for the sort order in your mocked up solution. I cannot see a pattern here .

 

[Fox21]

Apologies for any confusion. I want to find duplicates referring to Column C, As soon as I find duplicates I want to sort them accordingly(Like column G including the rows). I tried the sort method and it takes time(17min or so) or excel crashes to rearrange 500k rows. See for example "Shia moody(row7)" on the left hand side, was rearranged and sorted on the right hand side.

 

[Fox21]

Apologies for any confusion. I want to find duplicates referring to Column C, As soon as I find duplicates I want to sort them accordingly(Like column G including the rows). I tried the sort method and it takes time(17min or so) or excel crashes to rearrange 500k rows. See for example "Shia moody(row7)" on the left hand side, was rearranged and sorted on the right hand side.

My Code was an attempt to performing this task. If you can perform this task in fewer steps, it would be of great help. Please ignore my Sample code. My overall idea was to load these records in an array and then search for duplicates by looping within the array. If there is a duplicate found then I want to sort them by adding the duplicates to a collection. Once that is done I want it to write to another worksheet from the collection.

 

[Alex Blakenburg]

See if this gets you close.
I only outputs those IDs that appear more than once to a new sheet.

Sub GetDuplicates()
      
    Dim dict As Object
    Dim coll As Collection
    Dim oPeople As clsPeople
    Dim wb As Workbook
    Dim sht As Worksheet
    Dim rng As Range
    Dim i As Long
    Dim dKey As Variant
    Dim outSht As Worksheet
    Dim outRow As Long
   
    Set wb = ThisWorkbook
    Set sht = ActiveSheet
    Set dict = CreateObject("Scripting.Dictionary")
    Set rng = sht.Range("A1").CurrentRegion
   
    For i = 2 To rng.Columns(3).Cells.Count
        Set oPeople = New clsPeople
        oPeople.Firstname = Cells(i, 1).Value
        oPeople.Surname = Cells(i, 2).Value
        oPeople.ID = Cells(i, 3).Value
       
        If dict.exists(Cells(i, 3).Value) Then
            dict(Cells(i, 3).Value).Add oPeople
        Else
            Set coll = New Collection
            coll.Add oPeople
            dict.Add Cells(i, 3).Value, coll
        End If

    Next i
   
    Set outSht = wb.Worksheets.Add(before:=wb.Worksheets(1))
    outRow = 1
    With outSht.Cells(outRow, 1).Resize(1, rng.Rows(1).Cells.Count)
        .Value = rng.Rows(1).Value
        .Font.Bold = True
    End With
   
    For Each dKey In dict
        Set coll = dict(dKey)
        ' only output if duplicates exist
        If coll.Count > 1 Then
            For i = 1 To coll.Count
                outRow = outRow + 1
                Set oPeople = coll(i)
                outSht.Cells(outRow, 1).Value = oPeople.Firstname
                outSht.Cells(outRow, 2).Value = oPeople.Surname
                outSht.Cells(outRow, 3).Value = oPeople.ID
               
            Next i
        End If
   
    Next dKey
   
    outSht.Range("A1").CurrentRegion.EntireColumn.AutoFit

End Sub

The next section is a class object (using the term very loosely) called clsPeople

Option Explicit

Public Firstname As String
Public Surname As String
Public ID As Long

 

[Alex Blakenburg]

I just realised that for 500k rows I should have used and array for reading & writing, so this is likely to be too slow.
Let me know how you go and I can revisit it tomorrow if need be.

 

[Alex Blakenburg]

See if this is any faster.

Sub GetDuplicatesArrayWIP()
    
    Dim dict As Object
    Dim coll As Collection
    Dim oPeople As clsPeople
    Dim wb As Workbook
    Dim sht As Worksheet
    Dim rng As Range
    Dim i As Long
    Dim dKey As Variant
    Dim outSht As Worksheet
    Dim outRow As Long
    Dim arr As Variant
    Dim outcoll As Collection
    Dim outArr()
    
    Set wb = ThisWorkbook
    Set sht = ActiveSheet
    Set dict = CreateObject("Scripting.Dictionary")
    Set rng = sht.Range("A1").CurrentRegion
    arr = rng
    
    For i = 2 To UBound(arr, 1)
        Set oPeople = New clsPeople
        oPeople.Firstname = arr(i, 1)
        oPeople.Surname = arr(i, 2)
        oPeople.ID = arr(i, 3)
        
        If dict.exists(arr(i, 3)) Then
            dict(arr(i, 3)).Add oPeople
        Else
            Set coll = New Collection
            coll.Add oPeople
            dict.Add arr(i, 3), coll
        End If

    Next i
    
    Set outSht = wb.Worksheets.Add(before:=wb.Worksheets(1))
    outRow = 1
    With outSht.Cells(outRow, 1).Resize(1, rng.Rows(1).Cells.Count)
        .Value = rng.Rows(1).Value
        .Font.Bold = True
    End With
    
    Set outcoll = New Collection
    For Each dKey In dict
        Set coll = dict(dKey)
        ' only output if duplicates exist
        If coll.Count > 1 Then
            For i = 1 To coll.Count
                outcoll.Add coll(i)
            Next i
        End If
    
    Next dKey
    
    ReDim outArr(1 To outcoll.Count, 1 To 3)
    For i = 1 To outcoll.Count
        Set oPeople = outcoll(i)
        outArr(i, 1) = oPeople.Firstname
        outArr(i, 2) = oPeople.Surname
        outArr(i, 3) = oPeople.ID
    Next i
    
    outSht.Range("A2").Resize(UBound(outArr), 3) = outArr
    outSht.Range("A1").CurrentRegion.EntireColumn.AutoFit

End Sub

 

[Fox21]

See if this is any faster.

Sub GetDuplicatesArrayWIP()
   
    Dim dict As Object
    Dim coll As Collection
    Dim oPeople As clsPeople
    Dim wb As Workbook
    Dim sht As Worksheet
    Dim rng As Range
    Dim i As Long
    Dim dKey As Variant
    Dim outSht As Worksheet
    Dim outRow As Long
    Dim arr As Variant
    Dim outcoll As Collection
    Dim outArr()
   
    Set wb = ThisWorkbook
    Set sht = ActiveSheet
    Set dict = CreateObject("Scripting.Dictionary")
    Set rng = sht.Range("A1").CurrentRegion
    arr = rng
   
    For i = 2 To UBound(arr, 1)
        Set oPeople = New clsPeople
        oPeople.Firstname = arr(i, 1)
        oPeople.Surname = arr(i, 2)
        oPeople.ID = arr(i, 3)
       
        If dict.exists(arr(i, 3)) Then
            dict(arr(i, 3)).Add oPeople
        Else
            Set coll = New Collection
            coll.Add oPeople
            dict.Add arr(i, 3), coll
        End If

    Next i
   
    Set outSht = wb.Worksheets.Add(before:=wb.Worksheets(1))
    outRow = 1
    With outSht.Cells(outRow, 1).Resize(1, rng.Rows(1).Cells.Count)
        .Value = rng.Rows(1).Value
        .Font.Bold = True
    End With
   
    Set outcoll = New Collection
    For Each dKey In dict
        Set coll = dict(dKey)
        ' only output if duplicates exist
        If coll.Count > 1 Then
            For i = 1 To coll.Count
                outcoll.Add coll(i)
            Next i
        End If
   
    Next dKey
   
    ReDim outArr(1 To outcoll.Count, 1 To 3)
    For i = 1 To outcoll.Count
        Set oPeople = outcoll(i)
        outArr(i, 1) = oPeople.Firstname
        outArr(i, 2) = oPeople.Surname
        outArr(i, 3) = oPeople.ID
    Next i
   
    outSht.Range("A2").Resize(UBound(outArr), 3) = outArr
    outSht.Range("A1").CurrentRegion.EntireColumn.AutoFit

End Sub

Okay. Will do. Thanks a Million