Excel VBA - Collection error

Question

I am trying to build a collection and take the Count of Unique Values from that Collection but am getting an error in building a Collection itself. Can anyone suggest me where I am going wrong. Kindly Share your thoughts. Please let me know how to find out the COUNT of UNIQUE VALUES as well.

Sub trial()

Dim sampleVisualBasicColl As Collection

For i = 2 To 10

    Rng = Range("M" & i).value

    StartsWith = Left(Rng, 3)

    If StartsWith = "Joh" Then

            sampleVisualBasicColl.Add Rng

    Else

    End If

Next

Debug.Print (sampleVisualBasicCol1)

End Sub

Answer 1

Using a collection you can just add Joh to the collection and then count the items:

'Using a collection
Sub Col_test()

    Dim cCol As Collection
    Dim i As Long

    Set cCol = New Collection

    On Error GoTo Err_Handler

    With ThisWorkbook.Worksheets("Sheet1")
        For i = 2 To 20
            If Left(.Cells(i, 13), 3) = "Joh" Then
                cCol.Add .Cells(i, 13).Value, .Cells(i, 13).Value
            End If
        Next i
    End With

    Debug.Print cCol.Count

    On Error GoTo 0

Exit Sub
Err_Handler:
    Select Case Err.Number
        Case 457 'This key is already associated with an element of this collection
            Err.Clear
            Resume Next
        Case Else
            MsgBox "Error " & Err.Number & vbCr & _
                " (" & Err.Description & ") in procedure Col_test."
            Err.Clear
    End Select

End Sub

If you want the count of each item (Joh, Ben... whatever else you have) then use a dictionary:

'Using a dictionary.
Sub Dic_Test()

    Dim dict As Object
    Dim i As Long
    Dim sValue As String
    Dim key As Variant

    Set dict = CreateObject("Scripting.Dictionary")

    With ThisWorkbook.Worksheets("Sheet1")
        For i = 2 To 20
            If Len(.Cells(i, 13)) >= 3 Then
                sValue = Left(.Cells(i, 13), 3)
                If dict.exists(sValue) Then
                    dict(sValue) = dict(sValue) + 1
                Else
                    dict(sValue) = 1
                End If
            End If
        Next i
    End With

    For Each key In dict.keys
        Debug.Print key & " = " & dict(key)
    Next key

End Sub

Note: I'm using Cells within the code rather than Range. Cells(2,13) is M2 (13th column, 2nd row).

I find this link very helpful with dictionaries: https://excelmacromastery.com/vba-dictionary/

As a further update (after answer accepted) and using the lists you gave in your question here: Excel VBA - Formula Counting Unique Value error this code with dictionaries will return Joh = 4, Ian = 3

'Using a dictionary.
Sub Dic_Test()

    Dim dict As Object
    Dim dictFinal As Object
    Dim i As Long
    Dim sValue As String
    Dim key As Variant
    Dim keyFinal As String

    Set dict = CreateObject("Scripting.Dictionary")
    Set dictFinal = CreateObject("Scripting.Dictionary")

    'Get the unique values from the worksheet.
    With ThisWorkbook.Worksheets("Sheet1")
        For i = 2 To 20
            If Len(.Cells(i, 13)) >= 3 Then
                sValue = .Cells(i, 13).Value
                If dict.exists(sValue) Then
                    dict(sValue) = dict(sValue) + 1
                Else
                    dict(sValue) = 1
                End If
            End If
        Next i
    End With

    'Count the unique values in dict.
    For Each key In dict.keys
        keyFinal = Left(key, 3)
        If dictFinal.exists(keyFinal) Then
            dictFinal(keyFinal) = dictFinal(keyFinal) + 1
        Else
            dictFinal(keyFinal) = 1
        End If
    Next key

    For Each key In dictFinal.keys
        Debug.Print key & " = " & dictFinal(key)
    Next key

End Sub

Answer 2

Hey this code will help u since it's collecting Unique values in Listbox,,

Private Sub UserForm_Initialize() Dim cUnique As Collection Dim Rng As Range Dim Cell As Range Dim sh As Worksheet Dim vNum As Variant

Set sh = ThisWorkbook.Sheets("Sheet1") Set Rng = sh.Range("A2", sh.Range("A2").Value ="John". End(xlDown))

Set cUnique = New Collection

On Error Resume Next

For Each Cell In Rng.Cells cUnique.Add Cell.Value, CStr(Cell.Value) Next Cell

On Error GoTo 0

For Each vNum In cUnique Me.ListBox1.AddItem vNum

Next vNum End Sub

Answer 3

You need to create the collection as well as declaring it.

Sub trial()

Dim myCol As Collection

Set myCol= New Collection ' creates the collection

For i = 2 To 10

    Rng = Range("M" & i).value

    StartsWith = Left(Rng, 3)

    If StartsWith = "Joh" Then

            myCol.Add Rng

    Else

    End If

Next

For each x in myCol
   Debug.Print x
Next x

End Sub

Answer 4

You have not declared Variable Rng & i these are the most important thing to do. Meanwhile I would like to suggest this Formula,,

=Sum(if(Frequency (if(Len(B2 :B20) >0,Match(B2 :B20, B2 :B20, 0),""),if(Len(B2 :B20) >Match(B2 :B20, B2 :B20, 0),"",))>0,1))

Its Array formula so finish with Ctrl +shift +enter.

You can use this one also,

Sub CountUnique()Dim i, count, j As Integer count = 1 For i = 1 To 470 flag = False If count

1 Then For j = 1 To count If Sheet1.Cells(i, 3).Value = Sheet1.Cells(j, 11).Value Then flag = True End If Next j Else flag = False End If If flag = False Then Sheet1.Cells(count, 11 ).Value = Sheet1.Cells(i, 3).Value count = count + 1 End IfNext i Sheet1.Cells( 1 , 15 ).Value = count End Sub