Excel：用其他列中的countifs樣式條件計算一列中唯一的逗號分隔字符串

Question

希望就此問題提供有關Excel / VBA向導的幫助。 我對自己的需求有可能的願景，但缺乏將其付諸實踐的專業知識。

本質上，該問題結合了使用countifs公式（具有多個條件）以及計算包含逗號分隔的字符串的列中的唯一字符串，如下所示：

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

^在這個超級簡化的示例中，這就像在計算Criteria1 = A＆criteria2 = Y時計算唯一名稱一樣。Answer = 3（Cam，Dan，Ava）

到目前為止，我已經能夠找到一個VBA解決方案（從這里開始 ），該解決方案可以在給定的列（例如上面的“名稱”）中計算唯一的字符串，但是我不知道如何將其與countifs樣式的條件結合起來以僅通過某些名稱的一部分屬於該功能。

我創建了一個xlsm電子表格，可以用更好的樣本數據，預期結果以及到目前為止我提供的部分VBA解決方案進一步闡述該問題：

XLSX

編輯：我正在使用Excel 2013

edit2：除了xlsm之外，還上傳了xlsx。 我當前正在使用的VBA代碼如下。 請注意，我將此表格復制到另一個來源，但我不太了解scripting.dictionary的工作方式：/

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：上面的代碼只是用;分隔字符串對給定范圍內的唯一值進行計數。 我不知道的部分是如何修改它以接受paramArray條件

Answer 1

考慮：

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

Answer 2

這是在使用字典的UDF中：

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

將其放在模塊中，就可以像公式一樣調用它：

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

---

根據評論編輯

這將允許使用Array條目，這將允許許多條件：

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

然后，將其輸入為以下數組公式：

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

作為數組公式，退出編輯模式而不是Enter時需要使用Ctrl-Shift-Enter進行確認。 如果操作正確，則Excel會將{}放在公式周圍。

如果需要更多條件，則將另一個布爾乘數添加到IF（）語句的第一個條件中的現有條件。 因此，如果您想測試Z列是否大於0，則可以在B列測試之后添加* ($Z$2:$Z$5>0) 。

---

這是一個使用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

它的輸入類似於SUMIFS，COUNTIFS。

第一個標准是需要划分和計數的范圍。

第二個是分隔符。

然后其余部分成對輸入。

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

Answer 3

我采取了另一種可能更復雜的方法。 您可以直接在工作表上指定條件。

該函數是UniqueNames（數據范圍，名稱范圍，規則范圍，可選的AndRules = True，可選的PrintNames = False）

這是我的樣品表

我在4次使用該功能
UniqueNames(A1:F11,G1:G11,A13:B16,FALSE) （“ E16”）as UniqueNames(A1:F11,G1:G11,A13:B16,FALSE)
UniqueNames(A1:F11,G1:G11,A13:B16) （“ E17”）as UniqueNames(A1:F11,G1:G11,A13:B16)
UniqueNames(A1:F11,G1:G11,A13:B16,FALSE,TRUE) （“ F16”）as UniqueNames(A1:F11,G1:G11,A13:B16,FALSE,TRUE)
UniqueNames(A1:F11,G1:G11,A13:B16,,TRUE) （“ F17”）as UniqueNames(A1:F11,G1:G11,A13:B16,,TRUE)

以下條件運算符是可接受的=,<,>,<=,>=,!=
運算符后必須跟一個空格，然后
-恆定值， 例如Complete
-值的函數， 例如Status（Project＃6）
空條件無效

代碼如下： 注意：還有一個私有函數

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