VBA to count unique cells based on criteria

Hi, I've been using a formula to count unique, but it takes a long time to process.

There are 50 similar calculations, so I though moving it to VBA and only running it as needed might speed things up.

I have code to count unique in a column (from mrexcel.com, thread 48385), but now I would like to set that against critera from other columns.  So I want to count unique in C:C, if D:D = "x"
I'll also want to expand that to count C:C if D:D = "x" AND E:E ="y"

Could anyone help with the modifications?

Thank you
Sub CntUnique2()
Dim Uni  As Collection, cl As Range, LpRange As Range
Dim clswfrm As Range, clswcst As Range, myRng As Range
Dim TotUni As Long
'*************
Set myRng = Sheets("raw").[C:C] 'define your sheet/range
'*************
On Error Resume Next
Set clswfrm = myRng.SpecialCells(xlFormulas)
Set clswcst = myRng.SpecialCells(xlConstants)
Set myRng = Nothing 'free up memory
On Error GoTo 0
If clswfrm Is Nothing And clswcst Is Nothing Then
Exit Sub
ElseIf Not clswfrm Is Nothing And Not clswcst Is Nothing Then
Set LpRange = Union(clswcst, clswfrm)
ElseIf clswfrm Is Nothing Then Set LpRange = clswcst
Else: Set LpRange = clswfrm
End If
Set clswfrm = Nothing: Set clswcst = Nothing 'Free up memory
Set Uni = New Collection
On Error Resume Next
For Each cl In LpRange
Uni.Add cl.Value, CStr(cl.Value) 'assign unique key string
Next cl
On Error GoTo 0
Set LpRange = Nothing 'free up memory
TotUni = Uni.Count
Set Uni = Nothing ''free up memory
Application.Worksheets("report").Range("R17") = TotUni - 1 '-1 to remove the header
End Sub

Open in new window

TelMacoAsked:
Who is Participating?
 
Saqib Husain, SyedEngineerCommented:
Change

    Uni.Add cl.Value, CStr(cl.Value) 'assign unique key string

to

    If cl.Offset(0, 1) = "x" Then Uni.Add cl.Value, CStr(cl.Value) 'assign unique key string

and to

    If cl.Offset(0, 1) = "x" and cl.Offset(0, 2) = "y" Then Uni.Add cl.Value, CStr(cl.Value) 'assign unique key string
0
 
krishnakrkcCommented:
Hi,

Try this


Kris
Sub kTest()
    
    Dim ka, i   As Long, strConcat  As String
    
    Const Crit  As String = "x|y"
    
    With ActiveSheet
        ka = Intersect(.UsedRange, Range("c:e"))
    End With
    
    With CreateObject("scripting.dictionary")
        .comparemode = 1
        For i = 1 To UBound(ka, 1)
            strConcat = LCase$(ka(i, 2) & "|" & ka(i, 3))
            If strConcat = Crit Then
                .Item(ka(i, 1)) = Empty
            End If
        Next
        Range("g1").Value = "Unique Count"
        Range("g2").Value = .Count
    End With

End Sub

Open in new window

0
 
TelMacoAuthor Commented:
That's awesome,

Thank you both so much!

I'm going to run with ssaqibh's solution, it's fast and really simple to understand.  Also it makes it easy to apply the critera to columns that are not side by side, with the Offset part

Plus he posted it 1st ( ;

krishnakrkc I'll assign you some points too, since your suggestion works as well.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.