VBA to count unique cells based on criteria

Posted on 2011-05-05
Last Modified: 2012-05-11
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, 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

Question by:TelMaco
    LVL 43

    Accepted Solution


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


        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
    LVL 18

    Assisted Solution


    Try this

    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
            Range("g1").Value = "Unique Count"
            Range("g2").Value = .Count
        End With
    End Sub

    Open in new window


    Author Comment

    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.

    Write Comment

    Please enter a first name

    Please enter a last name

    We will never share this with anyone.

    Featured Post

    Looking for New Ways to Advertise?

    Engage with tech pros in our community with native advertising, as a Vendor Expert, and more.

    A little background as to how I came to I design this code: Around 5 years ago I designed an add-in that formatted Excel files to a corporate standard, applying different cell colours and font type depending on whether the cells contained inputs,…
    Entering a date in Microsoft Access can be tricky. A typo can cause month and day to be shuffled, entering the day only causes an error, as does entering, say, day 31 in June. This article shows how an inputmask supported by code can help the user a…
    Graphs within dashboards are meant to be dynamic, representing data from a period of time that will change each time the dashboard is updated with new data. Rather than update each graph to point to a different set within a static set of data, t…
    This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.

    779 members asked questions and received personalized solutions in the past 7 days.

    Join the community of 500,000 technology professionals and ask your questions.

    Join & Ask a Question

    Need Help in Real-Time?

    Connect with top rated Experts

    9 Experts available now in Live!

    Get 1:1 Help Now