Extract unique values from range using Dictionary

Guinaba

Board Regular
Joined
Sep 19, 2018
Messages
92
Hi guys,

Any help here is much appreciate it. I am trying to exctract the unique records from the range below using data dictionary but my code is not working, not sure what I am missing.

Range:
BrandColorShape
TotoBlueRound
TotoBlueRound
TotoBlueSquare
TotoBlueTriangular
GlaraGreenSquare
GlaraGreenSquare
GlaraBlackSquare
GlaraWhiteSquare

VBA Code:
Sub GetUnique()

    Dim Dict As Object
    Dim i As Long, j As Long
    Dim DRange() As Variant
    Dim LastRow, LastCol As Long, NumRows As Long, NumCols As Long
    LastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.count, 1).End(xlUp).Row
    Set DRange = Range("A1:D" & LastRow)
    Set Dict = CreateObject("Scripting.Dictionary")
    
    'Convert range to array and count rows and columns
    NumRows = UBound(DRange)
    NumCols = UBound(DRange, 2)
     
    'put unique data elements in a dictionay
    Set Dict = CreateObject("Scripting.Dictionary")
    For i = 1 To NumCols
       For j = 1 To NumRows
          Dict(DRange(j, i)) = 1
       Next j
    Next i
       
    Range("F2").Resize(Dict.count) = Application.Transpose(Dict.keys)

End Sub
 

Some videos you may like

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.

Takae

Well-known Member
Joined
Jul 1, 2015
Messages
723
Hope this helps.

VBA Code:
Sub Sample()
    Dim Dic, buf As String, Keys
    Dim i As Long, LastRow  As Long
    
    Set Dic = CreateObject("Scripting.Dictionary")
    
    With Sheets("Sheet1")
        On Error Resume Next
        LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = 2 To LastRow
            buf = .Cells(i, 1).Value & "," & .Cells(i, 2).Value & "," & .Cells(i, 3).Value
            Dic.Add buf, buf
        Next
        On Error GoTo 0
        
        Keys = Dic.Keys
        For i = 0 To Dic.Count - 1
            .Range(.Cells(i + 2, 6), .Cells(i + 2, 8)) = Split(Keys(i), ",")
        Next
    
    End With
    Set Dic = Nothing
    
End Sub
 

Guinaba

Board Regular
Joined
Sep 19, 2018
Messages
92
Hope this helps.

VBA Code:
Sub Sample()
    Dim Dic, buf As String, Keys
    Dim i As Long, LastRow  As Long
   
    Set Dic = CreateObject("Scripting.Dictionary")
   
    With Sheets("Sheet1")
        On Error Resume Next
        LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = 2 To LastRow
            buf = .Cells(i, 1).Value & "," & .Cells(i, 2).Value & "," & .Cells(i, 3).Value
            Dic.Add buf, buf
        Next
        On Error GoTo 0
       
        Keys = Dic.Keys
        For i = 0 To Dic.Count - 1
            .Range(.Cells(i + 2, 6), .Cells(i + 2, 8)) = Split(Keys(i), ",")
        Next
   
    End With
    Set Dic = Nothing
   
End Sub
Hi @Takae,

That is awasome! Thank you!! It works perfeclty! Can I ask you why do you add -1 in the Dic.Count? For i = 0 To Dic.Count - 1
 

Takae

Well-known Member
Joined
Jul 1, 2015
Messages
723
The number of elements of "Keys" and "Dic" is 6, but the start of "keys" starts from 0 and ends with 5. If the loop 0 to 6(=Dic.count), it will be error because "keys" does not have element 6.
Please stop this line "For i = 0 To Dic.Count - 1" and check local window.
 

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
1,010
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

You just want to count unique

Just use Exists function in Dictionary to add to Dict if not yet available. After that just count how many item inside the Dict.

VBA Code:
Sub GetUnique()

    Dim Dict As Object
    Dim i As Long, j As Long, UniqueCount As Long
    Dim LastRow As Long, LastCol As Long
    Dim ws As Worksheet
   
    Set ws = ActiveWorkbook.Worksheets("Sheet1")
    LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    LastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
   
    Set Dict = CreateObject("Scripting.Dictionary")
   
    For i = 1 To LastCol
        For j = 2 To LastRow
            If Not Dict.Exists(ws.Cells(j, i)) Then
                Dict.Add ws.Cells(j, i), ws.Cells(j, i)
            End If
        Next
    Next
   
    UniqueCount = Dict.Count

End Sub
 
Solution

Guinaba

Board Regular
Joined
Sep 19, 2018
Messages
92
You just want to count unique

Just use Exists function in Dictionary to add to Dict if not yet available. After that just count how many item inside the Dict.

VBA Code:
Sub GetUnique()

    Dim Dict As Object
    Dim i As Long, j As Long, UniqueCount As Long
    Dim LastRow As Long, LastCol As Long
    Dim ws As Worksheet
  
    Set ws = ActiveWorkbook.Worksheets("Sheet1")
    LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    LastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
  
    Set Dict = CreateObject("Scripting.Dictionary")
  
    For i = 1 To LastCol
        For j = 2 To LastRow
            If Not Dict.Exists(ws.Cells(j, i)) Then
                Dict.Add ws.Cells(j, i), ws.Cells(j, i)
            End If
        Next
    Next
  
    UniqueCount = Dict.Count

End Sub
Thanks @Zot!
 

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
1,010
Office Version
  1. 2016
Platform
  1. Windows
Just an update.

The code I posted somehow cannot detect if key is already existed or not in Dictionary for whatever reason

The key entered as ws.Cells(j,i) cannot be detected with my Excel 2016. However, if the value is read first as variable, it will work. Probably it is just the Excel works. I thought my Excel got problem but after re-install my Excel, the same still happened. My revised code would be

VBA Code:
Sub GetUnique()

    Dim Dict As Object
    Dim strA$
    Dim i As Long, j As Long, UniqueCount As Long
    Dim LastRow As Long, LastCol As Long
    Dim ws As Worksheet
    
    Set ws = ActiveWorkbook.Worksheets("Sheet1")
    LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    LastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    
    Set Dict = CreateObject("Scripting.Dictionary")
    
    For i = 1 To LastCol
        For j = 2 To LastRow
            strA = ws.Cells(j, i)                                 ' Need to read as variable first (in this case string) to be able to work
            If Not Dict.Exists(strA) Then
                Dict.Add strA, strA
            End If
        Next
    Next
    
    UniqueCount = Dict.Count

End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,127,584
Messages
5,625,639
Members
416,124
Latest member
DeMoNloK

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top