Count Unique String Values Between Dates

[ryancgarrett]

I have a large data set with dates in column A, and alphanumeric strings in column B. I need to count the unique values in Column B between two dates in Column A. I've tried a few solutions, but due to the data size standard array formulas were freezing my workbook for 5-10 minutes. I found the following VBA formula which works great, but need to edit it to allow for the data criteria:

Function CountUnique(ListRange As Range) As IntegerDim CellValue As Variant
Dim UniqueValues As New Collection


    Application.Volatile


        On Error Resume Next


            For Each CellValue In ListRange


            UniqueValues.Add CellValue, CStr(CellValue) ' add the unique item


            Next


        CountUnique = UniqueValues.Count


End Function

 

[Eric W]

Try:

Function CountUnique(ListRange As Range, Date1 As Date, Date2 As Date) As Integer
Dim UniqueValues As New Collection
Dim MyData As Variant, i As Long

    Application.Volatile
    MyData = ListRange.Value
    On Error Resume Next

    For i = 1 To UBound(MyData)
        If MyData(i, 1) >= Date1 And MyData(i, 1) <= Date2 Then
            UniqueValues.Add MyData(i, 2), MyData(i, 2)                   ' add the unique item
        End If
    Next i
    CountUnique = UniqueValues.Count

End Function

Call it using

=countunique(A1:B20,D1,E1)

where A has your dates, B has the values, D1 has the start date, and E1 has the end date.

 

[Mentor82]

Hi,
Check if that's what you need.

Function CountUnique(ListRange As Range, CellValue as range) As Integer
Dim UniqueValues As New Collection


        On Error Resume Next


            For Each CellValue In ListRange


            UniqueValues.Add cstr(CellValue.value)


            Next


        CountUnique = UniqueValues.Count


End Function

[/QUOTE]

 

[mumps]

This macro will prompt you to enter a start date and end date.

Sub CountUniques()
    Application.ScreenUpdating = False
    Dim sDate As String, edate As String, LastRow As Long, rng As Range
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    sDate = InputBox("Please enter a start date using the format: yyyy/mm\dd")
    edate = InputBox("Please enter an end date using the format: yyyy/mm\dd")
    Range("A1:B" & LastRow).AutoFilter Field:=1, Criteria1:=">=" & CDate(sDate), Operator:=xlAnd, Criteria2:="<=" & CDate(edate)
    Set rnglist = CreateObject("Scripting.Dictionary")
    For Each rng In Range("B2:B" & LastRow).SpecialCells(xlCellTypeVisible)
        If Not rnglist.Exists(rng.Value) Then
            rnglist.Add rng.Value, Nothing
        End If
    Next rng
    Range("A1").AutoFilter
    MsgBox ("There are " & rnglist.count & " unique values between " & sDate & " and " & edate & ".")
    Application.ScreenUpdating = True
End Sub

 

[ryancgarrett]

Thanks Eric, worked perfectly. Could the formula be easily modified in case the data is not contiguous? I.e., =countunique(date array, value array, start date, end date)?

 

[Eric W]

Sure, try:

Function CountUnique(DateRange As Range, ValRange As Range, ByVal Date1 As Date, ByVal Date2 As Date) As Integer
Dim UniqueValues As New Collection
Dim MyDates As Variant, MyVals As Variant, i As Long

    Application.Volatile
    MyDates = DateRange.Value
    MyVals = ValRange.Value
    On Error Resume Next

    For i = 1 To UBound(MyDates)
        If MyDates(i, 1) >= Date1 And MyDates(i, 1) <= Date2 Then
            UniqueValues.Add MyVals(i, 1), MyVals(i, 1)                   ' add the unique item
        End If
    Next i
    CountUnique = UniqueValues.Count

End Function

Note that I read the arrays into memory to make it run as fast as possible.