' ZVI:2012-11-07 - http://www.mrexcel.com/forum/excel-questions/667989-udf-counting-unique-text-within-date-range.html
' Count unique values in Data with optional min/max boundaries MinValue, MaxValue in Cond.
' Arguments:
' Data - required, Range or Array with data values which unique count is returned
' Cond - optional, Range or Array with values for conditions MinValue or/and MaxValue
' MinValue - optional, minimum value in Cond range to allow counting
' MaxValue - optional, maximum value in Cond range to allow counting
' Examples:
' 1) UDF, count unique of A1:A9 without conditions
' =CountUnique( A1:A9 )
' 2) UDF, count unique of A1:A9 with B1:B9 >= DATE(2012,9,1)
' =CountUnique( A1:A9, B1:B9, DATE(2012,9,1) )
' 3) UDF, count unique of A1:A9 with B1:B9 <= DATE(2012,3,31)
' =CountUnique( A1:A9, B1:B9, , DATE(2012,3,31) )
' 4) UDF, count unique A1:A9 with B1:B9 >= DATE(2012,9,1) And B1:B9 <= DATE(2012,10,1)
' =CountUnique( A1:A9, B1:B9, DATE(2012,9,1), DATE(2012,10,1) )
' 5) VBA, count unique of a() with b() >= DATE(2012,9,1) And b() <= DATE(2012,10,1)
' n = CountUnique(a(), b(), DateSerial(2012, 9, 1), DateSerial(2012, 10, 1))
' Note: VBA arrays can be 1 or 2 dimensions but with the same LBounds and Ubounds
Function CountUnique(Data, Optional Cond, Optional MinValue, Optional MaxValue)
Dim a, b, v
Dim c As Long, e As Long, i As Long, r As Long
Dim LBa1 As Long, LBa2 As Long, UBa1 As Long, UBa2 As Long
Dim LBb1 As Long, LBb2 As Long, UBb1 As Long, UBb2 As Long
Dim Is1D As Boolean, Ok As Boolean
Dim k As String
' Save error number for the case it was present before calling this function
e = Err.Number
' Suppress stop on error
On Error Resume Next
' Configure conditional index
If Not IsMissing(MinValue) Then i = i + 1
If Not IsMissing(MaxValue) Then i = i + 2
' Copy Data values to a() array
a = Data
If Not IsArray(a) Then ReDim a(1 To 1, 1 To 1): a(1, 1) = Data
LBa1 = LBound(a, 1)
UBa1 = UBound(a, 1)
LBa2 = LBound(a, 2)
If Err = 0 Then UBa2 = UBound(a, 2) Else LBa2 = 1: UBa2 = 1: Is1D = True: Err.Clear
' Copy Cond values to b() array
If i > 0 Then
b = Cond
If Not IsArray(b) Then ReDim b(1 To 1, 1 To 1): b(1, 1) = Cond
LBb1 = LBound(b, 1)
UBb1 = UBound(b, 1)
LBb2 = LBound(b, 2)
If Err = 0 Then UBb2 = UBound(b, 2) Else LBb2 = 1: UBb2 = 1: Is1D = True: Err.Clear
' Compare dimentions of arrays
If LBa1 <> LBb1 Or UBa1 <> UBb1 Or LBa2 <> LBb2 Or UBa2 <> UBb2 Then CountUnique = "#Size!": Exit Function
End If
' Count unique values with/without conditions
With New Collection
For r = LBa1 To UBa1
For c = LBa2 To UBa2
k = vbNullString
If Is1D Then k = Trim(a(r)) Else k = Trim(a(r, c))
If Len(k) Then
Ok = False
If i = 0 Then
Ok = True
ElseIf i = 1 Then
If Is1D Then Ok = b(r) >= MinValue Else Ok = b(r, c) >= MinValue
ElseIf i = 2 Then
If Is1D Then Ok = b(r) <= MaxValue Else Ok = b(r, c) <= MaxValue
Else
If Is1D Then
Ok = b(r) >= MinValue And b(r) <= MaxValue
Else
Ok = b(r, c) >= MinValue And b(r, c) <= MaxValue
End If
End If
If Ok Then .Add vbNullString, k
End If
Next
Next
CountUnique = .Count
End With
' Restore saved error number
Err.Number = e
End Function
' Test VBA 1D-array processing
Sub Test5()
Dim a(), b()
' Copy A1:A9 to 1D-array
a() = WorksheetFunction.Transpose(Range("A1:A9"))
' To prevent date to string converting don't use Range("B1:B9").Value at transposing!
' Use just Range("B1:B9") without .Value
b() = WorksheetFunction.Transpose(Range("B1:B9"))
' Show result
Debug.Print CountUnique(a(), b(), DateSerial(2012, 9, 1), DateSerial(2012, 10, 1))
End Sub
