Excel: Count unique comma-delimited strings in a column with countifs-style criteria from other columns

Question

Hoping for help form an Excel/VBA wizard on this problem. I have a possible vision of what i need, but lack the expertise to pull it off.

Essentially the problem combines the use of a countifs formula (with multiple criteria) along with counting unique strings in a column containing comma-delimited strings like this:

Criteria1 | Criteria2 |Names
A         | X         |Bob
B         | Y         |Cam;Bob
A         | Y         |Dan;Ava
A         | Y         |Ava;Cam

^In this super-simplified example, it would be like counting unique names where Criteria1 = A & criteria2 = Y. Answer = 3 (Cam, Dan, Ava)

So far, i've been able to find a VBA solution (from here)that counts unique strings in a given column like "names" above, but I don't know how to combine that with countifs-style criteria to only pass certain parts of the names range to that function.

I have created an xlsm spreadsheet that further elaborates on the problem with better sample data, expected results and the partial VBA solution I have so far:

xlsx

edit: I'm using Excel 2013

edit2: uploaded xlsx in addition to xlsm. VBA code i'm currently using is below. Note that I copied this form another source and I don't really understand how the scripting.dictionary stuff works :/

Function cntunq(ByVal rng As Range)

' http://www.mrexcel.com/forum/excel-questions/437952-counting-unique-values-seperate-comma.html

Dim cl As Range, i As Integer
Dim dic1, ar
ar = Split(Replace(Join(Application.Transpose(rng), ";"), vbLf, ""), ";")
Debug.Print Join(ar, ";")
Set dic1 = CreateObject("Scripting.Dictionary")
dic1.CompareMode = vbTextCompare
For i = 0 To UBound(ar)
    dic1(ar(i)) = ""
Next i
cntunq = dic1.Count

End Function

Edit3: The above code just does the counting of unique values in a given range with ;-delimited strings. The part i don't know is how to modify this to take paramArray of conditions

Answer 1

Here it is in a UDF using a dictionary:

Function MyCount(critRng As Range, crit As String, critRng2 As Range, crit2 As String, cntRng As Range, delim As String) As Long
Dim critarr(), critarr2(), cntarr()
Set dict = CreateObject("Scripting.Dictionary")

critarr = critRng.Value
cntarr = cntRng.Value
critarr2 = critRng2.Value
If UBound(critarr, 1) <> UBound(cntarr, 1) Then Exit Function
For i = LBound(critarr, 1) To UBound(critarr, 1)
    If critarr(i, 1) = crit And critarr2(i, 1) = crit2 Then
        splt = Split(cntarr(i, 1), delim)
        For j = LBound(splt) To UBound(splt)
            On Error Resume Next
            dict.Add splt(j), splt(j)
            On Error GoTo 0
        Next j
    End If
Next i
MyCount = dict.Count
End Function

Put that in a module and you would call it like a formula:

=MyCount($A$2:$A$5,"A",$B$2:$B$5,"Y",$C$2:$C$5,";")

---

Edit as per Comments

This will allow an Array entry, which will allow many conditions:

Function MyCount2(delim As String, rsltArr()) As Long
Set dict = CreateObject("Scripting.Dictionary")
Dim splt() As String
Dim i&, j&
For i = LBound(rsltArr, 1) To UBound(rsltArr, 1)
    If rsltArr(i, 1) <> "False" And rsltArr(i, 1) <> "" Then
        splt = Split(rsltArr(i, 1), delim)
        For j = LBound(splt) To UBound(splt)
            On Error Resume Next
            dict.Add splt(j), splt(j)
            On Error GoTo 0
        Next j
    End If
Next i
MyCount2 = dict.Count
End Function

This then is entered as the following array formula:

=MyCount2(";",IF(($A$2:$A$5="A")*($B$2:$B$5="Y"),$C$2:$C$5))

Being an array formula it needs to be confirmed with Ctrl-Shift-Enter when exiting edit mode instead of Enter. If done correctly then Excel will put {} around the formula.

If you want more criteria, then add another Boolean multiply to the existing in the first criterion of the IF() statement. So if you wanted to test if column Z was greater than 0 you would add * ($Z$2:$Z$5>0) after the column B test.

---

Here is a non array formula that uses ParamArray.

Function MyCount3(cntrng As Range, delim As String, ParamArray t()) As Long
Set dict = CreateObject("Scripting.Dictionary")
Dim cntArr As Variant
cntArr = cntrng.Value
Dim tArr() As Boolean
Dim splt() As String
Dim I&, l&
Dim tpe As String
ReDim tArr(1 To t(0).Rows.Count)

For l = 1 To t(0).Rows.Count
    For I = LBound(t) To UBound(t) Step 2
        If Not tArr(l) Then
            If InStr("<>=", Left(t(I + 1), 1)) = 0 Then t(I + 1) = "=" & t(I + 1)
            If InStr("<>=", Mid(t(I + 1), 2, 1)) > 0 Then Z = 2 Else Z = 1
            tArr(l) = Application.Evaluate("NOT(""" & t(I).Item(l).Value & """" & Left(t(I + 1), Z) & """" & Mid(t(I + 1), Z + 1) & """)")
      End If
    Next I
Next l

For l = 1 To UBound(tArr)
    If Not tArr(l) Then
        splt = Split(cntArr(l, 1), delim)
        For j = LBound(splt) To UBound(splt)
            On Error Resume Next
            dict.Add splt(j), splt(j)
            On Error GoTo 0
        Next j
    End If
Next l
MyCount3 = dict.Count
End Function

It is entered similar to SUMIFS,COUNTIFS.

The first criterion is the range that needs to be split and counted.

The second is the delimiter on which it should split.

Then the rest is entered in pairs.

=MyCount3($C$2:$C$5,";",$A$2:$A$5,"A",$B$2:$B$5,"Y")

Answer 2

I took a different, possibly more complicated approach. You can specify the criteria directly on the sheet.

The function is UniqueNames(Range of Data, Range of Names, Range of Rules, Optional AndRules = True, Optional PrintNames = False)

Here is my sample sheet

I'm using the function 4 times in
- Range("E16") as UniqueNames(A1:F11,G1:G11,A13:B16,FALSE)
- Range("E17") as UniqueNames(A1:F11,G1:G11,A13:B16)
- Range("F16") as UniqueNames(A1:F11,G1:G11,A13:B16,FALSE,TRUE)
- Range("F17") as UniqueNames(A1:F11,G1:G11,A13:B16,,TRUE)

The following operators for conditions are acceptable =,<,>,<=,>=,!=
The operator must be followed by a single space and either
- a constant value e.g. Complete
- a function of a value, e.g. Status(Project#6)
An empty condition is invalid

Here's the code: Note: There is a private function as well

Public Function UniqueNames(DataSource As Range, ResultsSource As Range, RulesSource As Range, _
                            Optional AndRules As Boolean = True, Optional PrintNames As Boolean = False) As String
' Return N unique names and who

   ' Split Indexed Expressions
   Dim iChar As Integer
   ' Expression to eval
   Dim Expression() As String
   Dim expr As Variant
   ' Results
   Dim Results As Variant
   ' Get Data into variant array
   Dim Data As Variant
   ' Get Rules into variant array of NRows x 2
   Dim Rules As Variant

   iChar = 0
   Data = DataSource
   If RulesSource.Columns.Count = 1 Then
      Rules = Union(RulesSource, RulesSource.Offset(0, 1))
   ElseIf RulesSource.Columns.Count > 2 Then
      Rules = RulesSource.Resize(RulesSource.Rows.Count, 2)
   Else
      Rules = RulesSource
   End If

   Results = ResultsSource.Resize(ResultsSource.Rows.Count, UBound(Rules))

   For i = LBound(Rules) + 1 To UBound(Rules)
      For j = LBound(Data, 2) To UBound(Data, 2)
         If Rules(i, 1) = Data(1, j) Then
            ' rules must be "operator condition"
            Expression = Split(Rules(i, 2), " ", 2)
            Expression(1) = Trim(Expression(1))

            ' determine which expression is this
            ' Convert expression when an item of something e.g. EndDate(10)
            iChar = InStr(Expression(1), "(")
            If iChar > 0 Then
               expr = ExprToVal(Data, Left$(Expression(1), iChar - 1), _
                              Mid$(Expression(1), iChar + 1, Len(Expression(1)) - iChar - 1))
            Else
               expr = Expression(1)
            End If

            For k = LBound(Data, 1) + 1 To UBound(Data, 1)
               Results(k, i) = False
               Select Case (Expression(0))
                  Case "="
                     If Data(k, j) <> "" And LCase$(Data(k, j)) = LCase$(expr) Then Results(k, i) = True
                  Case "<"
                     If Data(k, j) <> "" And LCase$(Data(k, j)) < LCase$(expr) Then Results(k, i) = True
                  Case ">"
                     If Data(k, j) <> "" And LCase$(Data(k, j)) > LCase$(expr) Then Results(k, i) = True
                  Case "<="
                     If Data(k, j) <> "" And LCase$(Data(k, j)) <= LCase$(expr) Then Results(k, i) = True
                  Case ">="
                     If Data(k, j) <> "" And LCase$(Data(k, j)) >= LCase$(expr) Then Results(k, i) = True
                  Case "!="
                     If Data(k, j) <> "" And LCase$(Data(k, j)) <> LCase$(expr) Then Results(k, i) = True
               End Select
            Next k
         End If
      Next j
   Next i

   ' create one list where all three rules are true
   Data = Results
   Set Results = Nothing
   ReDim Results(LBound(Data, 1) + 1 To UBound(Data, 1), 1 To 2) As Variant

   ' results now has the names w/a number representing how many rules were met
   For i = LBound(Data, 1) + 1 To UBound(Data, 1)
      Results(i, 1) = Data(i, 1)
      Results(i, 2) = 0
      For j = LBound(Data, 2) + 1 To UBound(Data, 2)
         If Data(i, j) Then Results(i, 2) = Results(i, 2) + 1
      Next j
   Next i

   ' put that back into data
   Data = Results
   Set Results = Nothing
   Results = ""

   For i = LBound(Data, 1) + 1 To UBound(Data, 1)
      If Data(i, 2) = UBound(Rules, 1) - LBound(Rules, 1) Then
         Results = Results & Data(i, 1) & ";"
      ElseIf AndRules = False And Data(i, 2) > 0 Then
         Results = Results & Data(i, 1) & ";"
      End If
   Next i

   ' split that into expression
   Expression = Split(Results, ";")
   For i = LBound(Expression) To UBound(Expression)
      For j = i + 1 To UBound(Expression)
         If Expression(i) = Expression(j) Then Expression(j) = ""
      Next j
   Next i

   iChar = 0
   Results = ""
   For i = LBound(Expression) To UBound(Expression)
      If Expression(i) <> "" Then
         Results = Results & Expression(i) & ";"
         iChar = iChar + 1
      End If
   Next i

   UniqueNames = ""
   If PrintNames Then
      ' prints number of unique names and the names
      UniqueNames = Results
   Else
      ' prints number of unique names
      UniqueNames = CStr(iChar)
   End If

End Function

Private Function ExprToVal(Data As Variant, expr As String, Index As String) As Variant

   Dim Row As Integer
   Dim Col As Integer
   Dim sCol As Variant

   ' Get what type of data this is
   For i = LBound(Data, 2) To UBound(Data, 2)
      sCol = Replace(Index, Data(1, i), "", 1, 1, vbTextCompare)
      If IsNumeric(sCol) Then
         Col = i
         Exit For
      ElseIf LCase$(Left$(Index, Len(Data(1, i)))) = LCase$(Data(1, i)) Then
         Col = i
         Exit For
      End If
   Next i
   ' now find the row of the value
   For i = LBound(Data, 1) + 1 To UBound(Data, 1)
      If LCase$(Data(i, Col)) = LCase$(sCol) Then
         Row = i
         Exit For
      End If
   Next i
   ' find the column of the value
   For i = LBound(Data, 2) To UBound(Data, 2)
      If LCase$(Data(1, i)) = LCase$(expr) Then
         Col = i
         Exit For
      End If
   Next i

   If Row >= LBound(Data, 1) And Row <= UBound(Data, 1) And _
      Col >= LBound(Data, 2) And Col <= UBound(Data, 2) Then
      ExprToVal = Data(Row, Col)
   Else
      ExprToVal = ""
   End If
End Function

Answer 3

Consider:

Sub poiuyt()
    Dim N As Long, i As Long, c As Collection
    Set c = New Collection

    N = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To N
        If Cells(i, 1) = "A" And Cells(i, 2) = "Y" Then
            arr = Split(Cells(i, 3), ";")
                For Each a In arr
                    On Error Resume Next
                        c.Add a, CStr(a)
                    On Error GoTo 0
                Next a
        End If
    Next i      
    MsgBox c.Count      
End Sub