Excel VBA - Formula Counting Unique Value error

Question

I am trying to calculate the count of Unique values based on a condition.

For example,

For a value in column B, I am trying to count the Unique values in Column C through VBA.

I know how to do it using Excel formula -

 =SUMPRODUCT((B2:B12<>"")*(A2:A12=32)/COUNTIF(B2:B12,B2:B12))

that value for 32 is dynamic - Programmatically I am calling them inside my vba code as Name

This is my code :

Application.WorksheetFunction.SumProduct((rng <> "") * (rng2 = Name) / CountIfs(rng, rng))

This is the sample data with the requirement

Alternatively, I Concatenated both the columns for keeping it simple and hoping to identify the Unique values which starts with name* method.

I don't know where I am going wrong. Kindly share your thoughts.

Answer 1

You may try something like this...

Function GetUniqueCount(Rng1 As Range, Lookup As String) As Long
Dim x, dict
Dim i As Long, cnt As Long
Set dict = CreateObject("Scripting.Dictionary")
x = Rng1.Value
For i = 1 To UBound(x, 1)
    If x(i, 1) = Lookup Then
        dict.Item(x(i, 1) & x(i, 2)) = ""
    End If
Next i
GetUniqueCount = dict.Count
End Function

Then you can use it like below...

=GetUniqueCount($A$2:$B$10,C2)

Where A2:B10 is the data range and C2 is the name criteria.

Answer 2

I'd put the values into an array, create a temporary 2nd array and only add values to this array if they are not already present, and then replace the original array. Then it's just a simple matter to sum the unique values:

Sub Unique

dim arr(10) as variant, x as variant
dim arr2() as variant

for x = 1 to 10 ' or whatever
   arr(x) = cells(x, 1) ' or whatever
next x

arr2 = UniqueValuesArray(arr)

' now write some code to count the unique values, you get the idea

End Sub

---

Function UniqueValuesArray(arr As Variant) As Variant()

Dim currentRow, arrpos As Long
Dim uniqueArray() As Variant
Dim x As Long

arrpos = 0
ReDim uniqueArray(arrpos)

For x = 0 To UBound(arr)
    If UBound(Filter(uniqueArray, arr(x))) = -1 Then
        ReDim Preserve uniqueArray(arrpos)
        uniqueArray(arrpos) = arr(x)
        arrpos = arrpos + 1
    End If
Next x

UniqueValuesArray = uniqueArray

End Function