Excel: cuente cadenas exclusivas delimitadas por comas en una columna con criterios de estilo de conteo de otras columnas

Esperando ayuda, forma un asistente de Excel / VBA sobre este problema. Tengo una visión posible de lo que necesito, pero carezco de la experiencia necesaria para llevarlo a cabo.

Esencialmente, el problema combina el uso de una fórmula de conteos (con múltiples criterios) junto con el conteo de cadenas únicas en una columna que contiene cadenas delimitadas por comas como esta:

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

^ En este ejemplo súper simplificado, sería como contar nombres únicos donde Criteria1 = A & criteria2 = Y. Answer = 3 (Cam, Dan, Ava)

Hasta ahora, he podido encontrar una solución de VBA (desde aquí ) que cuente cadenas únicas en una columna dada como "nombres" arriba, pero no sé cómo combinar eso con los criterios de estilo de conteo para pasar solo ciertos partes de los nombres se extienden a esa function.

He creado una spreadsheet xlsm que profundiza en el problema con mejores datos de muestra, resultados esperados y la solución parcial de VBA que tengo hasta ahora:

xlsx

editar: estoy usando Excel 2013

edit2: xlsx cargado además de xlsm. El código de VBA que estoy usando actualmente está abajo. Tenga en count que copié este formulario en otra fuente y realmente no entiendo cómo funciona el 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: el código anterior simplemente hace el conteo de valores únicos en un range dado con; -delimited strings. La parte que no sé es cómo modificar esto para tomar paramArray de condiciones

Aquí está en un UDF usando un 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 

Ponlo en un module y lo llamarías como una fórmula:

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

enter image description here


Editar según los comentarios

Esto permitirá una input de Array, que permitirá muchas condiciones:

 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 

Esto luego se ingresa como la siguiente fórmula de matriz:

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

Al ser una fórmula de matriz, debe confirmarse con Ctrl-Shift-Enter al salir del modo de edición en lugar de Entrar. Si se hace correctamente, Excel colocará {} alnetworkingedor de la fórmula.

Si desea más criterios, agregue otro multiplicar boolean al existente en el primer criterio de la instrucción IF (). Entonces, si quisiera probar si la columna Z era mayor que 0, agregaría * ($Z$2:$Z$5>0) después de la testing de la columna B.

enter image description here


Aquí hay una fórmula no matriz que usa 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 

Se ingresa de manera similar a RESUMEN, CONTAR.

El primer criterio es el range que necesita ser dividido y contado.

El segundo es el delimitador en el que debe dividirse.

Luego, el rest se ingresa por parejas.

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

enter image description here

Considerar:

 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 

enter image description here

Tomé un enfoque diferente, posiblemente más complicado. Puede especificar los criterios directamente en la hoja.

La function es UniqueNames (Rango de datos, Rango de nombres, Rango de reglas, AndRules opcional = Verdadero, PrintNames opcionales = False)

Aquí está mi hoja de muestra enter image description here

Estoy usando la function 4 veces en
– Rango ("E16") como UniqueNames(A1:F11,G1:G11,A13:B16,FALSE)
– Rango ("E17") como UniqueNames(A1:F11,G1:G11,A13:B16)
– Rango ("F16") como UniqueNames(A1:F11,G1:G11,A13:B16,FALSE,TRUE)
– Rango ("F17") como UniqueNames(A1:F11,G1:G11,A13:B16,,TRUE)

Los siguientes operadores de condiciones son aceptables =,<,>,<=,>=,!=
El operador debe estar seguido de un espacio único y
– un valor constante, por ejemplo, completo
– una function de un valor, p . ej. Estado (Proyecto n. ° 6)
Una condición vacía no es válida

Aquí está el código: Nota: También hay una function privada

 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