Excel·VBA多条件筛选组合结果

Function strTOF(str$) As Boolean
    '用于计算字符串判断True/False，默认返回False
    '适用vba比较运算符；速度比较慢，但通用
    Dim i&, j&, m$, temp$, arr, brr, k, v, result As Boolean
    oper = "<>="    '比较运算符
    c = Len(str): ReDim k(1 To c), v(1 To c)
    For i = 1 To c
        m = Mid(str, i, 1)
        If InStr(oper, m) > 0 Then   '序号k数组，运算符v数组
            j = j + 1: k(j) = i: v(j) = m
        End If
    Next
    If j = 0 Then   'str无既定运算符
        strTOF = False: Exit Function
    ElseIf j = 1 Then
        strTOF = Application.Evaluate(str)
    ElseIf j > 1 Then
        ReDim Preserve v(1 To j): ReDim arr(1 To j)
        arr(1) = v(1): j = 1
        For i = 2 To UBound(v)
            If k(i) = k(i - 1) + 1 Then  '连续的运算符视为同一个运算符
                arr(j) = arr(j) & v(i)
            Else
                j = j + 1: arr(j) = v(i)
            End If
        Next
        ReDim Preserve arr(1 To j): temp = str
        For Each a In arr
            temp = Replace(temp, a, ",", 1, 1)  '替换运算符
        Next
        brr = Split(temp, ",")
        For i = 1 To UBound(arr)
            result = Application.Evaluate(brr(i - 1) & arr(i) & brr(i))
            If result = False Then strTOF = False: Exit Function  '一假为假
        Next
        If result Then strTOF = True    '全真为真
    End If
End Function

Sub 查找符合条件的组合_通用版()
    Dim dict As Object, i&, j&, x&, y&, n&, m1$, tf As Boolean, limit&, l&
    Set dict = CreateObject("scripting.dictionary"): tm = Timer
    '获取参数
    With ActiveSheet
        arr = .[a1].CurrentRegion.Value
        '参数1
        For i = 2 To UBound(arr)
            If Not dict.exists(arr(i, 1)) Then dict(arr(i, 1)) = i  '名称-行号
        Next
        c = .Cells(2, "o").End(xlToRight).Column
        name_1 = Range(.Cells(2, "o"), .Cells(2, c)).Value  '必选名称
        name_1 = WorksheetFunction.Transpose(WorksheetFunction.Transpose(name_1))
        x = 0: ReDim name_0(1 To UBound(arr))
        For Each k In dict.keys
            m = Application.Match(k, name_1, 0)
            If TypeName(m) = "Error" Then x = x + 1: name_0(x) = k  '非必选名称
        Next
        ReDim Preserve name_0(1 To x)
        '参数2，非必选名称组合，故n1最小值为1，n2最大值为非必选名称数
        n1 = .Cells(3, "o").Value: n2 = .Cells(3, "p").Value
        If n1 > UBound(name_1) Then n1 = n1 - UBound(name_1) Else n1 = 1
        If n2 > UBound(name_0) Then n2 = UBound(name_0)
        '参数3，返回结果上限，为0则输出全部结果
        limit = [o4]
        '参数4
        r = .Cells(2, "o").End(xlDown).Row
        crr = Range(.Cells(5, "o"), .Cells(r, "p")).Value
        arr1 = Application.Index(arr, 1)    '名称转列号
        For i = 1 To UBound(crr)
            crr(i, 1) = Application.Match(crr(i, 1), arr1, 0)
        Next
    End With
    '组合
    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "组合结果2"
    With ActiveSheet
        wrr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dict.keys))
        .[a1].Resize(1, UBound(wrr)) = wrr
        For i = n1 To n2
            brr = combin_arr1(name_0, i)  '调用组合函数
            For Each b In brr
                temp = Split(Join(name_1, ",") & "," & Join(b, ","), ",")  '拼接，临时数组
                ReDim t(UBound(temp)), trr(UBound(temp))
                For j = 0 To UBound(temp)  '名称转行号
                    t(j) = dict(temp(j))
                Next
                x = 0
                Do                         '条件判断
                    x = x + 1
                    For y = 0 To UBound(temp)
                        trr(y) = arr(t(y), crr(x, 1))
                    Next
                    m = WorksheetFunction.Median(trr)  '中位数
                    m1 = Replace(crr(x, 2), "x", m)    '替换数据
                    tf = strTOF(m1)                    '调用判断函数
                    If tf = False Then Exit Do
                Loop Until x >= UBound(crr)
                If tf = True Then
                    r = .UsedRange.Rows.Count + 1: l = l + 1  '写入行号，写入次数
                    If limit = 0 Or l <= limit Then
                        For j = 1 To UBound(wrr)
                            w = Application.Match(wrr(j), temp, 0)
                            If TypeName(w) <> "Error" Then .Cells(r, j).Value = 1
                        Next
                    Else    '超出结果上限则退出
                        Debug.Print "组合查找完成，累计用时：" & Format(Timer - tm, "0.00")  '耗时
                        Exit Sub
                    End If
                End If
            Next
        Next
    End With
    Debug.Print "组合查找完成，累计用时：" & Format(Timer - tm, "0.00")  '耗时
End Sub
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113

注意： 以上代码调用了《Excel·VBA数组组合函数、组合求和》 combin_arr1函数

对于一组数据按照一定数量进行组合，按照既定条件筛选符合的结果

数据

条件

条件1中，“必选名称”每个组合结果必须有，因此仅对“非必选名称”进行组合；
因此，条件2中的上下限为最终结果的组合元素个数，但在代码中会转换为“非必选名称”的组合元素个数的上下限
为实现条件4判断组合对应的某几列的中位数是否符合既定条件，单独定义strTOF函数判断字符串True/False，例如：

Debug.Print strTOF("1<=2<=3")    '返回True
1

专门的函数判断True/False便于条件4指定不定数量的筛选条件时，不用修改代码就可运行，但也必然导致代码运行速度下降，因而固定条件的筛选不必如此使用函数

结果 —— 部分截图
符合条件的组合结果，在名称下标1，每行为一个组合

附件
百度网盘：《Excel·VBA多条件筛选组合结果（附件）》，提取码：jrk8