ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH云课堂-专业的职场技能充电站 Excel转在线管理系统,怎么做看这里 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 高效办公必会的Office实战技巧 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 3668|回复: 25

[求助] 多条件排列组合

[复制链接]

TA的精华主题

TA的得分主题

发表于 2016-1-3 16:55 | 显示全部楼层 |阅读模式
本帖最后由 学不完用不尽 于 2016-1-27 21:52 编辑

说明:本想在“香川群子”大师的代码基础上进行修改,没能成功。特邀请“香川群子”大师帮忙。
根据设定的条件,对数据进行排列组合。
要求参见附件:
多条件排列组合.rar (24.21 KB, 下载次数: 95)

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-1-3 21:41 | 显示全部楼层
勉强修改成功,输出结果基本正确,请“香川群子”大师雅正,谢谢!
  1. Option Explicit
  2. Dim sj1, sj2, sj3, jg(), k&, L&, m&, n&
  3. Sub Combin_kagawa2()
  4.     Dim sj, i, kk, j
  5.         With Sheets("排列组合")
  6.             sj = .Range("a1").CurrentRegion.Offset(1)
  7.             sj3 = .Range("o2:r2")
  8.             ReDim sj2(1 To 1000, 1 To UBound(sj))
  9.             L = 0: i = 0
  10.             Do
  11.                 i = i + 1: n = sj(i, 1)
  12.                 If n Then
  13.                     L = L + 1: k = 0
  14.                     Do
  15.                        If sj(i, 2) <> "" Then
  16.                             ReDim sj1(1 To UBound(sj, 2))
  17.                             For j = 1 To UBound(sj, 2)
  18.                                 If sj(i, j + 1) = "" Then Exit For Else sj1(j) = sj(i, j + 1)
  19.                             Next
  20.                             m = j - 1
  21.                             Call dgZH("", 0, 1)
  22.                         End If
  23.                         If sj(i + 1, 1) <> "" Then Exit Do Else i = i + 1
  24.                     Loop Until i = UBound(sj)
  25.                     If k > kk Then kk = k
  26.                 End If
  27.             Loop Until i = UBound(sj)
  28.             m = kk: n = L: k = 0
  29.             .[a2].Offset(UBound(sj) + 7).CurrentRegion = ""
  30.             .[a2].Offset(UBound(sj) + 7).Resize(m, n) = sj2
  31.             ReDim jg(60000, 0)
  32.             Call dgMN("", 1)
  33.             If k = 0 Then MsgBox "无此排列组合,请重新设置条件!": Exit Sub
  34.             .[w2].CurrentRegion = ""
  35.             .[w2] = "共有" & k & "种组合"
  36.             .[w3].Resize(k) = jg
  37.         End With
  38. End Sub

  39. Sub dgZH(r$, i%, t%)
  40.     Dim j%, jj, sjgw
  41.     For j = i + 1 To m - n + t
  42.        If t < n Then
  43.        sjgw = Val(Right(Mid(r & "," & sj1(j), 2), 1))
  44.        For jj = 1 To 4
  45.        If sjgw = sj3(1, jj) Then
  46.        Call dgZH(r & "," & sj1(j), j, t + 1)
  47.        End If
  48.        Next jj
  49.        Else
  50.        sjgw = Val(Right(Mid(r & "," & sj1(j), 2), 1))
  51.        For jj = 1 To 4
  52.        If sjgw = sj3(1, jj) Then
  53.        k = k + 1
  54.        sj2(k, L) = Mid(r & "," & sj1(j), 2)
  55.        End If
  56.        Next jj
  57.        End If
  58.     Next
  59. End Sub

  60. Sub dgMN(r$, j%)
  61.     Dim i%, jj, sjgw, sjgw1, sjgw2
  62.     For i = 1 To m
  63.         If sj2(i, j) <> "" Then
  64.         If j < n Then
  65.         Call dgMN(r & "," & sj2(i, j), j + 1)
  66.         Else
  67.         sjgw = Mid(r, 2) & "," & sj2(i, j)
  68.         sjgw1 = Split(sjgw, ",")
  69.         For jj = 0 To UBound(sjgw1)
  70.         sjgw2 = sjgw2 & "," & Right(sjgw1(jj), 1)
  71.         Next jj
  72.         sjgw2 = Mid(sjgw2, 2)
  73.         If InStr(sjgw2, sj3(1, 1)) > 0 And InStr(sjgw2, sj3(1, 2)) > 0 Then
  74.         If InStr(sjgw2, sj3(1, 3)) > 0 And InStr(sjgw2, sj3(1, 4)) > 0 Then
  75.         jg(k, 0) = sjgw
  76.         k = k + 1
  77.         End If
  78.         End If
  79.         sjgw2 = ""
  80.         End If
  81.         End If
  82.     Next
  83. End Sub
复制代码

多条件排列组合(改自香川组合).rar

24.53 KB, 下载次数: 106

TA的精华主题

TA的得分主题

发表于 2016-1-3 21:55 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-1-4 15:06 | 显示全部楼层
添加动态条件:
  1. Option Explicit
  2. Dim sj1, sj2, sj3, jg(), k&, L&, m&, n&, col
  3. Sub Combin_kagawa2()
  4.     Dim sj, i, kk, j
  5.         With Sheets("排列组合")
  6.             sj = .Range("a1").CurrentRegion.Offset(1)
  7.             col = .[q2]
  8.             sj3 = .Range(.[o4], .Cells(4, 14 + col))
  9.             ReDim sj2(1 To 1000, 1 To UBound(sj))
  10.             L = 0: i = 0
  11.             Do
  12.                 i = i + 1: n = sj(i, 1)
  13.                 If n Then
  14.                     L = L + 1: k = 0
  15.                     Do
  16.                        If sj(i, 2) <> "" Then
  17.                             ReDim sj1(1 To UBound(sj, 2))
  18.                             For j = 1 To UBound(sj, 2)
  19.                                 If sj(i, j + 1) = "" Then Exit For Else sj1(j) = sj(i, j + 1)
  20.                             Next
  21.                             m = j - 1
  22.                             Call dgZH("", 0, 1)
  23.                         End If
  24.                         If sj(i + 1, 1) <> "" Then Exit Do Else i = i + 1
  25.                     Loop Until i = UBound(sj)
  26.                     If k > kk Then kk = k
  27.                 End If
  28.             Loop Until i = UBound(sj)
  29.             m = kk: n = L: k = 0
  30.             .[a2].Offset(UBound(sj) + 7).CurrentRegion = ""
  31.             .[a2].Offset(UBound(sj) + 7).Resize(m, n) = sj2
  32.             ReDim jg(60000, 0)
  33.             Call dgMN("", 1)
  34.             If k = 0 Then MsgBox "无此排列组合,请重新设置条件!": Exit Sub
  35.             .[w2].CurrentRegion = ""
  36.             .[w2] = "共有" & k & "种组合"
  37.             .[w3].Resize(k) = jg
  38.         End With
  39. End Sub

  40. Sub dgZH(r$, i%, t%)
  41.     Dim j%, jj, sjgw
  42.     For j = i + 1 To m - n + t
  43.        If t < n Then
  44.        sjgw = Val(Right(Mid(r & "," & sj1(j), 2), 1))
  45.        For jj = 1 To col
  46.        If sjgw = sj3(1, jj) Then
  47.        Call dgZH(r & "," & sj1(j), j, t + 1)
  48.        End If
  49.        Next jj
  50.        Else
  51.        sjgw = Val(Right(Mid(r & "," & sj1(j), 2), 1))
  52.        For jj = 1 To col
  53.        If sjgw = sj3(1, jj) Then
  54.        k = k + 1
  55.        sj2(k, L) = Mid(r & "," & sj1(j), 2)
  56.        End If
  57.        Next jj
  58.        End If
  59.     Next
  60. End Sub

  61. Sub dgMN(r$, j%)
  62.     Dim i%, jj, sjgw, sjgw1, sjgw2
  63.     For i = 1 To m
  64.         If sj2(i, j) <> "" Then
  65.         If j < n Then
  66.         Call dgMN(r & "," & sj2(i, j), j + 1)
  67.         Else
  68.         sjgw = Mid(r, 2) & "," & sj2(i, j)
  69.         sjgw1 = Split(sjgw, ",")
  70.         For jj = 0 To UBound(sjgw1)
  71.         sjgw2 = sjgw2 & "," & Right(sjgw1(jj), 1)
  72.         Next jj
  73.         sjgw2 = Mid(sjgw2, 2)
  74.         If col = 2 Then
  75.         If InStr(sjgw2, sj3(1, 1)) > 0 And InStr(sjgw2, sj3(1, 2)) > 0 Then
  76.         jg(k, 0) = sjgw
  77.         k = k + 1
  78.         End If
  79.         ElseIf col = 3 Then
  80.         If InStr(sjgw2, sj3(1, 1)) > 0 And InStr(sjgw2, sj3(1, 2)) > 0 Then
  81.         If InStr(sjgw2, sj3(1, 3)) > 0 Then
  82.         jg(k, 0) = sjgw
  83.         k = k + 1
  84.         End If
  85.         End If
  86.         ElseIf col = 4 Then
  87.         If InStr(sjgw2, sj3(1, 1)) > 0 And InStr(sjgw2, sj3(1, 2)) > 0 Then
  88.         If InStr(sjgw2, sj3(1, 3)) > 0 And InStr(sjgw2, sj3(1, 4)) > 0 Then
  89.         jg(k, 0) = sjgw
  90.         k = k + 1
  91.         End If
  92.         End If
  93.         ElseIf col = 5 Then
  94.         If InStr(sjgw2, sj3(1, 1)) > 0 And InStr(sjgw2, sj3(1, 2)) > 0 Then
  95.         If InStr(sjgw2, sj3(1, 3)) > 0 And InStr(sjgw2, sj3(1, 4)) > 0 Then
  96.         If InStr(sjgw2, sj3(1, 5)) > 0 Then
  97.         jg(k, 0) = sjgw
  98.         k = k + 1
  99.         End If
  100.         End If
  101.         End If
  102.         End If
  103.         sjgw2 = ""
  104.         End If
  105.         End If
  106.     Next
  107. <span style="line-height: 1.5;">End Sub</span>
复制代码

多条件排列组合(改自香川组合).rar

24.19 KB, 下载次数: 72

TA的精华主题

TA的得分主题

发表于 2016-1-5 16:42 | 显示全部楼层
代码不需要那么复杂:

  1. Dim sj(), jg(), m&, n&, k&
  2. Sub test() 'by kagawa 2106/1/5
  3.     Dim i&, j&, l&, cl&, r&, t&, tms#
  4.     tms = Timer
  5.    
  6.     m = [a1].End(4).Row
  7.     ReDim a&(9)
  8.     For i = 2 To m
  9.         a(Cells(i, 1)) = 1 '提取尾数
  10.     Next
  11.    
  12.     cl = [a1].End(2).Column
  13.     n = WorksheetFunction.Sum([b1].Resize(, cl - 1))
  14.     If n <> 5 Then MsgBox "n <> 5 Err !": Exit Sub
  15.    
  16.     m = 7
  17.     ReDim sj(1 To m, 1 To n)
  18.     n = 0: r = 1
  19.     For j = 2 To cl '遍历数据区各列
  20.         For l = 1 To Cells(1, j) '按第1行指定有效次数重复
  21.             n = n + 1: i = 0 '行位置 i 初始化、列数=n
  22.             For k = 1 To 7
  23.                 t = k + (j - 2) * 7 '生成数据表
  24.                 If a(t Mod 10) Then i = i + 1: sj(i, n) = t '符合尾数的则提取
  25.             Next
  26.             r = r * i '理论组合次数
  27.         Next
  28.     Next
  29.     [b11].Resize(m, n) = sj '输出整理后的数据表
  30.    
  31.     ReDim jg(r, n) '存放结果的数组
  32.    
  33.     k = 0: Call dgMN(1) '调用香川多列组合的递归过程

  34.     MsgBox Format(Timer - tms, "0.000s ") & k
  35.     [a1].Offset(, n + 3).CurrentRegion.Offset(1) = ""
  36.     [a1].Offset(1, n + 3).Resize(k, n + 1) = jg
  37.    
  38. End Sub

  39. Sub dgMN(j&)
  40.     Dim i&, l&
  41.     For i = 1 To m
  42.         If sj(i, j) = 0 Then Exit For '本列为空时退出
  43.         If sj(i, j) > jg(k, j - 1) Then '确保每个组合中的数值为升序且不重复
  44.             jg(k, j) = sj(i, j)
  45.             If j = n Then
  46.                 k = k + 1: jg(k - 1, 0) = k
  47.                 For l = 1 To n - 1
  48.                     jg(k, l) = jg(k - 1, l)
  49.                 Next
  50.             Else
  51.                 Call dgMN(j + 1)
  52.             End If
  53.         End If
  54.     Next
  55. End Sub
复制代码

CombinTest.zip

22.43 KB, 下载次数: 91

评分

参与人数 1鲜花 +2 收起 理由
学不完用不尽 + 2 谢谢!有一点美中不足

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-1-5 22:07 | 显示全部楼层
香川群子 发表于 2016-1-5 16:42
代码不需要那么复杂:

貌似遗漏了一个条件:结果中必须包含所有的尾数,缺一不可。
多条件排列组合2.jpg

TA的精华主题

TA的得分主题

发表于 2016-1-6 11:06 | 显示全部楼层
组合完成后,增加一个检查不重复尾数个数是否符合要求的代码。

CombinTest-2.zip

22.47 KB, 下载次数: 98

评分

参与人数 1鲜花 +2 收起 理由
学不完用不尽 + 2 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-1-6 22:36 | 显示全部楼层
香川群子 发表于 2016-1-6 11:06
组合完成后,增加一个检查不重复尾数个数是否符合要求的代码。

非常感谢!OK!!完美!!!
看看你写的代码,再比对一下我修改的代码,天壤之别。
能否再提一个小小的请求:利用和值(最小和值和最大和值之间,和值指的是一组组合中的所有数字之和)对组合完成后的结果进一步进行筛选。

TA的精华主题

TA的得分主题

发表于 2016-1-6 23:32 | 显示全部楼层
当然可以。你自己先举个例子吧。

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-1-7 11:05 | 显示全部楼层
香川群子 发表于 2016-1-6 23:32
当然可以。你自己先举个例子吧。

就是有效组合必须在一定的和值范围内。
排列组合.jpg

烦请修改一下代码,谢谢!
CombinTest-2.rar (20.36 KB, 下载次数: 48)
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

最新热点上一条 /1 下一条

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2019-8-25 08:56 , Processed in 0.111842 second(s), 15 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表