Excel：使用来自其他列的countifs样式条件对列中唯一的以逗号分隔的string进行计数

希望在这个问题上帮助形成一个Excel / VBA向导。 我有一个可能的愿景，我需要什么，但缺乏专业知识来推动它。

本质上，这个问题结合了使用countifs公式（带有多个标准）以及在包含以逗号分隔的string的列中计算唯一string，如下所示：

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）

到目前为止，我已经能够find一个VBA解决scheme（从这里 ），计算上面的“名称”给定的列中的唯一string，但我不知道如何将它与countifs样式标准结合起来，只通过某些部分名称范围到该function。

我已经创build了一个xlsm电子表格，以进一步阐述更好的示例数据，预期的结果以及到目前为止的部分VBA解决scheme：

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：上面的代码只是用给定范围内的唯一值进行计数：-defined strings。 我不知道的部分是如何修改这个paramArray的条件

Answer 1

这是使用字典的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,";") 

---

按照评论编辑

这将允许一个数组项，这将允许许多条件：

 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 

然后按照以下数组公式input：

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

作为一个数组公式，在退出编辑模式而不是Enter时，需要用Ctrl-Shift-Enter确认。 如果正确完成，则Excel将在公式周围放置{} 。

如果您需要更多条件，则在IF（）语句的第一个条件中将另一个布尔乘法添加到现有条件中。 所以如果你想testingZ列是否大于0，你会在B列testing后加上* ($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 

它被input类似于SUMIFS，COUNTIFS。

第一个标准是需要分割和计算的范围。

第二个是它应该分割的分隔符。

然后其余的成对input。

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

Answer 2

考虑：

 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 3

我采取了不同的，可能更复杂的方法。 您可以直接在工作表上指定标准。

函数是UniqueNames（数据范围，名称范围，规则范围，可选AndRules = True，可选PrintNames = False）

这是我的样品表

我正在使用该function4次
– 范围（“E16”）作为UniqueNames(A1:F11,G1:G11,A13:B16,FALSE)
– 范围（“E17”）作为UniqueNames(A1:F11,G1:G11,A13:B16)
– 范围（“F16”）为UniqueNames(A1:F11,G1:G11,A13:B16,FALSE,TRUE)
– 范围（“F17”）为UniqueNames(A1:F11,G1:G11,A13:B16,,TRUE)

条件的以下运算符可接受=,<,>,<=,>=,!=
运营商必须跟随一个单一的空间
– 一个常数值， 例如Complete
– 一个值的函数， 例如状态（项目＃6）
一个空的条件是无效的

这是代码： 注意：还有一个私人的function

 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 eg 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