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

Function strTOF(str$) As Boolean'用于计算字符串判断True/False，默认返回False'适用vba比较运算符；速度比较慢，但通用Dim i&, j&, m$, temp$, arr, brr, k, v, result As Booleanoper = "<>="    '比较运算符c = Len(str): ReDim k(1 To c), v(1 To c)For i = 1 To cm = Mid(str, i, 1)If InStr(oper, m) > 0 Then   '序号k数组，运算符v数组j = j + 1: k(j) = i: v(j) = mEnd IfNextIf j = 0 Then   'str无既定运算符strTOF = False: Exit FunctionElseIf j = 1 ThenstrTOF = Application.Evaluate(str)ElseIf j > 1 ThenReDim Preserve v(1 To j): ReDim arr(1 To j)arr(1) = v(1): j = 1For i = 2 To UBound(v)If k(i) = k(i - 1) + 1 Then  '连续的运算符视为同一个运算符arr(j) = arr(j) & v(i)Elsej = j + 1: arr(j) = v(i)End IfNextReDim Preserve arr(1 To j): temp = strFor Each a In arrtemp = Replace(temp, a, ",", 1, 1)  '替换运算符Nextbrr = 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  '一假为假NextIf result Then strTOF = True    '全真为真End If
End FunctionSub 查找符合条件的组合_通用版()Dim dict As Object, i&, j&, x&, y&, n&, m1$, tf As Boolean, limit&, l&Set dict = CreateObject("scripting.dictionary"): tm = Timer'获取参数With ActiveSheetarr = .[a1].CurrentRegion.Value'参数1For i = 2 To UBound(arr)If Not dict.exists(arr(i, 1)) Then dict(arr(i, 1)) = i  '名称-行号Nextc = .Cells(2, "o").End(xlToRight).Columnname_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.keysm = Application.Match(k, name_1, 0)If TypeName(m) = "Error" Then x = x + 1: name_0(x) = k  '非必选名称NextReDim Preserve name_0(1 To x)'参数2，非必选名称组合，故n1最小值为1，n2最大值为非必选名称数n1 = .Cells(3, "o").Value: n2 = .Cells(3, "p").ValueIf n1 > UBound(name_1) Then n1 = n1 - UBound(name_1) Else n1 = 1If n2 > UBound(name_0) Then n2 = UBound(name_0)'参数3，返回结果上限，为0则输出全部结果limit = [o4]'参数4r = .Cells(2, "o").End(xlDown).Rowcrr = Range(.Cells(5, "o"), .Cells(r, "p")).Valuearr1 = Application.Index(arr, 1)    '名称转列号For i = 1 To UBound(crr)crr(i, 1) = Application.Match(crr(i, 1), arr1, 0)NextEnd With'组合Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "组合结果2"With ActiveSheetwrr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dict.keys)).[a1].Resize(1, UBound(wrr)) = wrrFor i = n1 To n2brr = combin_arr1(name_0, i)  '调用组合函数For Each b In brrtemp = Split(Join(name_1, ",") & "," & Join(b, ","), ",")  '拼接，临时数组ReDim t(UBound(temp)), trr(UBound(temp))For j = 0 To UBound(temp)  '名称转行号t(j) = dict(temp(j))Nextx = 0Do                         '条件判断x = x + 1For y = 0 To UBound(temp)trr(y) = arr(t(y), crr(x, 1))Nextm = WorksheetFunction.Median(trr)  '中位数m1 = Replace(crr(x, 2), "x", m)    '替换数据tf = strTOF(m1)                    '调用判断函数If tf = False Then Exit DoLoop Until x >= UBound(crr)If tf = True Thenr = .UsedRange.Rows.Count + 1: l = l + 1  '写入行号，写入次数If limit = 0 Or l <= limit ThenFor j = 1 To UBound(wrr)w = Application.Match(wrr(j), temp, 0)If TypeName(w) <> "Error" Then .Cells(r, j).Value = 1NextElse    '超出结果上限则退出Debug.Print "组合查找完成，累计用时：" & Format(Timer - tm, "0.00")  '耗时Exit SubEnd IfEnd IfNextNextEnd WithDebug.Print "组合查找完成，累计用时：" & Format(Timer - tm, "0.00")  '耗时
End Sub

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

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

数据

条件

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

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

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

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

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

Excel·VBA多条件筛选组合结果相关推荐

Excel VBA 多条件筛选及汇总统计
Excel VBA 多条件筛选 AdvancedFilter 汇总统计 sumproduct Range与Array交换在日常工作中,面对Excel表格数据,为了分类进行统计,通过对表格数据筛选获取 ...
Excel·VBA指定条件删除整行整列
目录 1,删除工作表所有空行 2,删除工作表所有空列 3,删除选中单列包含指定字符的行举例 3.1,改进版 4,删除选中单列不含指定字符的行举例 5,删除选中列重复的整行举例 6,删除选中列唯一 ...
Excel·VBA自定义函数筛选单元格区域重复值
贴吧提问<哪位大神知道要怎么实现?>,Excel内置函数使用比较麻烦,VBA字典实现比较直观自定义函数UNIQUE_IF筛选单元格区域中的值,可以选择返回其中的唯一值或重复值,并用分隔符 ...
Excel操作-多条件筛选
一.背景一般情况下,Excel多条件筛选,可以直接打开数据栏下的"筛选"功能,然后多值勾选即可. 但是如果可选项过多,通过多值勾选的方式实现多条件筛选就不现实了.这里可以通过使用 ...
向内存中连续存入数据_实例35_在Excel中按条件筛选数据并存入新的表
老板想要看去年每月领料数量大于1000的数据.手动筛选并复制粘贴出来,需要重复操作12次,实在太麻烦了,还是让Python来做吧.磨刀不误砍柴工,先整理一下思路: 1. 读取原表,将数量大于1000的 ...
在Excel中按条件筛选数据并存入新的表
案例老板想要看去年每月领料数量大于1000的数据.手动筛选并复制粘贴出来,需要重复操作12次,实在太麻烦了,还是让Python来做吧.磨刀不误砍柴工,先整理一下思路: 1·读取原表,将数量大于100 ...
Access/VBA/Excel-多条件筛选数据-10
微信公众号原文系统:Windows 7 软件:Excel 2010 / Access 2010 这个系列开展一个新的篇章,重点关注Access数据库主体框架:以Excel作为操作界面,Access ...
Excel VBA 高级编程-跨表格多条件筛选
大家好,我是陈小虾,是一名自动化方向的IT民工.写博客是为了记录自己的学习过程,通过不断输出倒逼自己加速成长.但由于水平有限,博客中难免会出现一些BUG,或者有更优方案恳请各位大佬不吝赐教!微信公众号 ...
Excel指定条件筛选
Excel VBA高级筛选,通过动态修改查询条件进行筛选(CriteriaRange 条件),将筛选结果写入指定单元格(A7). Sub 宏1() ' ' 宏1 宏 ''Range("A7: ...

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

Excel·VBA多条件筛选组合结果相关推荐

最新文章

热门文章