Sub COMBOX()
Dim AL As Object: Set AL = CreateObject("System.Collections.ArrayList")
Dim SD As Object: Set SD = CreateObject("Scripting.Dictionary")
Dim Data() As Variant: Data = Range("B2:H" & Range("A" & Rows.Count).End(xlUp).Row).Value2
Dim Grp As Integer: Grp = 7
Dim Tot As Integer: Tot = 7
Dim b As Boolean: b = True
Dim i As Integer
Dim r As Range
For i = 1 To Grp
Main AL, i, Tot
Next i
For Each AI In AL
SP = Split(AI, ",")
For ro = 1 To UBound(Data)
b = True
For Each s In SP
If Data(ro, s) <> 1 Then b = False
Next s
If b Then SD(AI) = SD(AI) + 1
Next ro
Next AI
With Range("M1:O1")
.Value = Array("Combo", "Count", "Percent")
.Font.Bold = True
End With
Set r = Range("M2").Resize(SD.Count)
r.Value2 = Application.Transpose(SD.keys)
r.Offset(, 1).Value2 = Application.Transpose(SD.items)
With r.Offset(, 2)
.Formula2R1C1 = "=RC[-1]/10"
.Value = .Value2
.NumberFormat = "#,##0%"
End With
End Sub
Sub Main(AL As Object, Grp As Integer, Tot As Integer)
Dim AR() As Variant: AR = Evaluate("TRANSPOSE(INDEX(ROW(1:" & Tot & "),))")
Combo AR, Grp, 1, 0, "", AL
End Sub
Sub Combo(AR() As Variant, Grp As Integer, IDX As Integer, Depth As Integer, Buffer As String, AL As Object)
Dim Prefix As String
For i = IDX To UBound(AR)
If Buffer = vbNullString Then
Prefix = AR(i)
Else
Prefix = Join(Array(Buffer, AR(i)), ",")
End If
If Depth + 1 = Grp Then
AL.Add Prefix
Else
Combo AR, Grp, i + 1, Depth + 1, Prefix, AL
End If
Next i
End Sub
