Extract unique values from range using Dictionary

[Guinaba]

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:

Brand	Color	Shape
Toto	Blue	Round
Toto	Blue	Round
Toto	Blue	Square
Toto	Blue	Triangular
Glara	Green	Square
Glara	Green	Square
Glara	Black	Square
Glara	White	Square

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

 

[Takae]

Hope this helps.

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]

Hope this helps.

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]

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]

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.

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

 

[Guinaba]

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.

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]

Thanks @Zot!

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

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