Counting unique rows

I have a column of names related by a column of numbers corresponding to each name. Each name is connected to a number and the same number can repeat. I want to count how many times a name occurs removing duplicates.

Here is an example of the problem

Quote from KjBox

Would VBA solution be acceptable?

Yes it would

Quote from KjBox

OK, I assume that all the colours in column B will have a number in column C and you are looking for a result that will give counts of each unique colour/number combinations. Is that correct?

Yes

Quote from Carim

Re,

Is the formula in Message # 4 producing your expected result ... or not ?

Unfortunately not

Quote from Carim

Do you mind explaining why ....

When I applied this formula to a large data set it returned 0, could be because it only works for manually selected rows

Quote from Carim

1. Have you adjusted the ranges to their actual sizes ...?

2. Have you noticed in cell G2 ... the word Blue ... cannot be written Blue :

1. I adjusted the ranges and I still receive 0, it only works on a small data set

2. No I haven't, I'm not sure why it can't be written like that

Looks like the *(B1:B10=G2) part of the formula is returning 0 for all values even for the value in G2

Quote from Carim

If you highlight exactly this portion (B1:B10=G2)

and Hit F9 to evaluate ...

you should see : {FALSE;FALSE;TRUE;FALSE;FALSE;TRUE;FALSE;TRUE;FALSE;TRUE}

Then for my data set the return values are all false when selecting rows A1:A34538. The value I am looking for occurs 8 times within the column with duplicates. I replaced G2 with the value I am looking for using the same format.

Quote from KjBox

Try this, click the button on the sheet to display counts

Code assigned to the button is

Code

Sub UniqueCounts()
    Dim x, y, e, i As Long, oDic1 As Object, oDic2 As Object
    Set oDic1 = CreateObject("scripting.dictionary")
    Set oDic2 = CreateObject("scripting.dictionary")
    
    With ActiveSheet
        x = .Cells(1).CurrentRegion
        With oDic1
            For i = 1 To UBound(x, 1)
                If Not .exists(x(i, 2)) Then
                    If Not oDic2.exists(x(i, 2) & " " & x(i, 3)) Then
                        oDic2.Add x(i, 2) & " " & x(i, 3), Nothing
                        .Add x(i, 2), 1
                    End If
                ElseIf Not oDic2.exists(x(i, 2) & " " & x(i, 3)) Then
                    oDic2.Add x(i, 2) & " " & x(i, 3), Nothing
                    .Item(x(i, 2)) = .Item(x(i, 2)) + 1
                End If
            Next
            ReDim y(1 To .Count, 1 To 2): i = 0
            For Each e In .keys
                i = i + 1
                y(i, 1) = e: y(i, 2) = .Item(e)
            Next
        End With
        .Columns(5).Resize(, 2).Clear
        .[e1].Resize(UBound(y, 1), 2) = y
    End With
    
End Sub

Display More

I wanted to count one value but this would be fine, thank you