VBA to show the count of unique records

Hi
I have a excel file were i'm using more than 25000 cells and most of the records in it will be duplicate records. In order to get the unique records im using the "Remove duplicate option" but were as to make my summary report im using a formula to count the unique records thus increasing my file size gradually since im going to use it for more records.

So i wanted to check the possibility to do this using vba to preserve my file size.

It may not be very clear with my explanation, so i have attached the sample file.

Thanks

if you want to count the unique records only then single cell solution is
copy paste below in C2 then hold control and shift then hit enter to make it array formula
=SUM(IF(FREQUENCY(MATCH(A2:A75,A2:A75,0),MATCH(A2:A75,A2:A75,0))>=1,1,0))

change the references as per of your actual data

if you want to have unique records preserving your actual data then select your data with headers then go to data tab---> Sort and Filter -----> Select Advance.
select copy to another location (enter the cell where you want your unique data to start) hit Ok.

@hemesh

Good one hemesh.

Originally Posted by sktneer

@hemesh

Good one hemesh.

Thanks Sktneer !

Moreover if you want to do it through VBA code, try this code......

Sub countunique()
Dim rng, chkrng, cell As Range
Dim lr As Long, n, count As Integer
lr = Cells(Rows.count, 1).End(xlUp).Row
Set rng = Range("A2:A" & lr)
For Each cell In rng
    Set chkrng = Range("A2:A" & cell.Row)
    n = WorksheetFunction.CountIf(chkrng, cell)
    If n = 1 Then
        count = count + 1
    End If
Next cell
MsgBox "Unique Records in the column A are " & count
End Sub

Hello muralidaran,

Here is the fastest method to use in VBA for finding unique values. On my computer it would take about 1.3 seconds to scan 25000 rows and return the unique records.

The attached workbook has the macro below added to it and a button on the worksheet to run it. All previous values in the "Uniques" column are cleared each time the macro is run.

Sub GetUniqueValues()

    Dim DstRng  As Range
    Dim Dict    As Object
    Dim EndRow  As Long
    Dim Key     As Variant
    Dim Rng     As Range
    Dim Wks     As Worksheet
    
        Set Wks = Sheet1
        
        Set DstRng = Wks.Range("D2")
            EndRow = Wks.Cells(Rows.Count, DstRng.Column).End(xlUp).Row
            If EndRow >= DstRng.Row Then DstRng.Resize(EndRow - DstRng.Row + 1, 1).ClearContents
        
        Set Rng = Wks.Range("A2")
            EndRow = Wks.Cells(Rows.Count, Rng.Column).End(xlUp).Row
            If EndRow < Rng.Row Then Exit Sub Else Set Rng = Rng.Resize(EndRow - Rng.Row + 1, 1)
            
            Set Dict = CreateObject("Scripting.Dictionary")
            Dict.CompareMode = vbTextCompare
            
            For Each Key In Rng.Cells
                Key = Trim(Key)
                If Key <> "" Then
                    If Not Dict.Exists(Key) Then
                        Dict.Add Key, 1
                    End If
                End If
            Next Key
            
        If Dict.Count > 1 Then
            DstRng.Resize(Dict.Count, 1).Value = Application.Transpose(Dict.Keys)
        Else
            DstRng.Value = Dict.Keys
        End If
    
End Sub

@ Leith Ross,

Hello Leith,

What an excellent piece of Coding!

Just to ensure D1 does not lose its heading, I would tweak your Code as follow.

Option Explicit
Sub GetUniqueValues()

    Dim DstRng  As Range
    Dim Dict    As Object
    Dim EndRow  As Long
    Dim Key     As Variant
    Dim Rng     As Range
    Dim Wks     As Worksheet
    
        Set Wks = Sheet1
        Wks.Range("D1") = "Unique Values"
        
        Set DstRng = Wks.Range("D2")
            EndRow = Wks.Cells(Rows.Count, DstRng.Column).End(xlUp).Row
            If EndRow >= DstRng.Row Then DstRng.Resize(EndRow - DstRng.Row + 1, 1).ClearContents
        
        Set Rng = Wks.Range("A2")
            EndRow = Wks.Cells(Rows.Count, Rng.Column).End(xlUp).Row
            If EndRow < Rng.Row Then Exit Sub Else Set Rng = Rng.Resize(EndRow - Rng.Row + 1, 1)
            
            Set Dict = CreateObject("Scripting.Dictionary")
            Dict.CompareMode = vbTextCompare
            
            For Each Key In Rng.Cells
                Key = Trim(Key)
                If Key <> "" Then
                    If Not Dict.Exists(Key) Then
                        Dict.Add Key, 1
                    End If
                End If
            Next Key
            
        If Dict.Count > 1 Then
            DstRng.Resize(Dict.Count, 1).Value = Application.Transpose(Dict.Keys)
        Else
            DstRng.Value = Dict.Keys
        End If
    
End Sub

Kind Regards.

Hello Winon,

Thanks for the tweak. I have included it in the updated macro and workbook.

Sub GetUniqueValues()

    Dim DstRng  As Range
    Dim Dict    As Object
    Dim EndRow  As Long
    Dim Key     As Variant
    Dim Rng     As Range
    Dim Wks     As Worksheet
    
        Set Wks = Sheet1
        
        Wks.Range("D1:E1") = Array("Uniques", "Count")
        
        Set DstRng = Wks.Range("D2:E2")
            EndRow = Wks.Cells(Rows.Count, DstRng.Column).End(xlUp).Row
            If EndRow >= DstRng.Row Then DstRng.Resize(EndRow - DstRng.Row + 1, 2).ClearContents
        
        Set Rng = Wks.Range("A2")
            EndRow = Wks.Cells(Rows.Count, Rng.Column).End(xlUp).Row
            If EndRow < Rng.Row Then Exit Sub Else Set Rng = Rng.Resize(EndRow - Rng.Row + 1, 1)
            
            Set Dict = CreateObject("Scripting.Dictionary")
            Dict.CompareMode = vbTextCompare
            
            For Each Key In Rng.Cells
                Key = Trim(Key)
                If Key <> "" Then
                    If Not Dict.Exists(Key) Then
                        Dict.Add Key, 1
                    Else
                        Dict(Key) = Dict(Key) + 1
                    End If
                End If
            Next Key
            
        Set DstRng = DstRng.Resize(Dict.Count, 2)
        
        If Dict.Count > 1 Then
            DstRng.Columns(1).Value = Application.Transpose(Dict.Keys)
            DstRng.Columns(2).Value = Application.Transpose(Dict.Items)
        Else
            DstRng.Columns(1).Value = Dict.Keys
            DstRng.Columns(2).Value = Dict.Items
        End If
    
End Sub

Thanks everyone.....
Mr. Leith Ross your code works fine but my requirement is to show the running count in column B, could you please help me to provide VBA code to show the running total in column B.

Thanks.

Hi muralidaran,

I'll let Leith provide an answer on his fantastic code, but I'd thought I'd also post this as a possible alternative to simply return the count of the unique entries in a range:

Option Explicit
Sub Macro1()

    Dim lngStartRow As Long
    Dim strMyCol As String
    Dim lngLastRow As Long
    Dim dblUniqueCount As Double
    
    lngStartRow = 2 'Starting row number for the data. Change to suit.
    strMyCol = "B" 'Column letter containing the data. Change to suit.
    lngLastRow = Cells(Rows.Count, strMyCol).End(xlUp).Row
    
    On Error Resume Next
        dblUniqueCount = Evaluate("SUM(IF(FREQUENCY(MATCH(" & strMyCol & lngStartRow & ":" & strMyCol & lngLastRow & "," & strMyCol & lngStartRow & ":" & strMyCol & lngLastRow & ",0),MATCH(" & strMyCol & lngStartRow & ":" & strMyCol & lngLastRow & "," & strMyCol & lngStartRow & ":" & strMyCol & lngLastRow & ",0))>=1,1,0))")
    On Error GoTo 0
    
    MsgBox dblUniqueCount

End Sub

Regards,

Robert

Hello muralidaran,

Here is the updated macro. This will provide you with a running total in column "B". It has been added to the attached workbook.

Sub GetUniqueValues()

    Dim Cell    As Range
    Dim DstRng  As Range
    Dim Dict    As Object
    Dim EndRow  As Long
    Dim Key     As Variant
    Dim n       As Long
    Dim Rng     As Range
    Dim Wks     As Worksheet
    
    
        Set Wks = Sheet1
        
        Set DstRng = Wks.Range("D2:E2")
            EndRow = Wks.Cells(Rows.Count, DstRng.Column).End(xlUp).Row
            If EndRow >= DstRng.Row Then DstRng.Resize(EndRow - DstRng.Row + 1, 2).ClearContents
        
        Set Rng = Wks.Range("A2")
            EndRow = Wks.Cells(Rows.Count, Rng.Column).End(xlUp).Row
            If EndRow < Rng.Row Then Exit Sub Else Set Rng = Rng.Resize(EndRow - Rng.Row + 1, 1)
            
            Set Dict = CreateObject("Scripting.Dictionary")
            Dict.CompareMode = vbTextCompare
            
        Application.ScreenUpdating = False
        
            For Each Cell In Rng.Cells
                Key = Trim(Cell)
                If Key <> "" Then
                    If Not Dict.Exists(Key) Then
                        Dict.Add Key, 1
                        Cell.Offset(0, 1).Value = 1
                    Else
                        n = Dict(Key) + 1
                        Dict(Key) = n
                        Cell.Offset(0, 1).Value = n
                    End If
                End If
            Next Cell
            
        Application.ScreenUpdating = True
        
End Sub

Hi Leith Ross
Thanks for the code, working as required.

Hello muralidaran,

You're welcome. My apologies for not understanding what you wanted initially.