Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2238|回复: 2

[已解决]请教数据累计相加10后交叉组合的宏

[复制链接]
发表于 2015-12-22 17:54 | 显示全部楼层 |阅读模式
本帖最后由 海水鱼 于 2015-12-23 13:10 编辑

请看附件谢谢!
最佳答案
2015-12-23 12:52
代码注释
  1. Dim sj, jg(), i1&, m&, n&, k& '定义递归过程需调用的公用变量
  2. Sub test() 'by kagawa
  3.     Dim ar, h&, i2&, j&, tms#
  4.     tms = Timer '程序开始时间
  5.    
  6.     ar = [b5].CurrentRegion '读取原始数据到数组ar
  7.     n = UBound(ar, 2) '得到展开列数n
  8.    
  9.     h = [d1] '读取D1限制最大值h
  10.     m = h \ 10 '计算累计+10需要的最大行数m
  11.     k = UBound(ar) * (m + 1) ^ n '估计全部组合个数k
  12.     ReDim jg(k, n): k = 0 '定义存放组合结果的数组jg、并初始化记录位置k

  13.     For i1 = 1 To UBound(ar) '遍历原始数据各行
  14.         ReDim sj(m, n) '矩阵数组sj初始化
  15.         For i2 = 0 To m '各行累计+10直到限额
  16.             For j = 1 To n '各列+10处理
  17.                 If ar(i1, j) < h - 10 * i2 Then sj(i2, j) = ar(i1, j) + 10 * i2 '不超限额时+10
  18.             Next
  19.         Next
  20.         Call dgMN(1) '调用【香川多列组合】的递归算法过程
  21.     Next
  22.     [b5].Offset(, n + 1).CurrentRegion.Offset(1) = "" '清空输出区域
  23.     [b5].Offset(, n + 1).Resize(k, n + 1) = jg '输出结果
  24.     MsgBox Format(Timer - tms, "0.00s ") & k '提示程序耗时 和 结果总数k
  25. End Sub

  26. Sub dgMN(j&) '【香川多列组合】的递归算法过程
  27.     Dim i&, l&, t
  28.     For i = 0 To m '遍历数据矩阵sj各行
  29.         t = sj(i, j) '读取该位置数值t
  30.         If t = "" Then Exit For '如为空(超过限额)则退出
  31.         If t > jg(k, j - 1) Then '如比左侧数据大则有效(排除无效组合)
  32.             jg(k, j) = t '写入此数值t
  33.             If j = n Then '如已到组合最后1列(满足组合列数=n)
  34.                 jg(k, 0) = i1 '记录该组合的原始数据行序号
  35.                 k = k + 1 '组合记录位置k+1
  36.                 For l = 1 To n - 1 '复制该组合数据到下一组
  37.                     jg(k, l) = jg(k - 1, l)
  38.                 Next
  39.             Else
  40.                 Call dgMN(j + 1) '不足n列时继续深入递归去组合下1列
  41.             End If
  42.         End If
  43.     Next
  44. End Sub
复制代码

请教数据累计相加10后交叉组合的宏.zip

7.35 KB, 下载次数: 8

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2015-12-23 12:33 | 显示全部楼层
1. 原始数据固定为B5开始的各列。列数可自由扩展
2. 按行展开、各个元素累计+10直至不超过D1值
3. 按累计+10处理后得到的数据矩阵,进行多列组合展开。
4. 组合中每1列元素自左至右升序的为有效组合。
5. 输出全部有效组合。第1列为对应的原始数据行序号。
  by Excel Home 香川群子 2015/12/23

10.zip

11.18 KB, 下载次数: 8

回复

使用道具 举报

发表于 2015-12-23 12:52 | 显示全部楼层    本楼为最佳答案   
代码注释
  1. Dim sj, jg(), i1&, m&, n&, k& '定义递归过程需调用的公用变量
  2. Sub test() 'by kagawa
  3.     Dim ar, h&, i2&, j&, tms#
  4.     tms = Timer '程序开始时间
  5.    
  6.     ar = [b5].CurrentRegion '读取原始数据到数组ar
  7.     n = UBound(ar, 2) '得到展开列数n
  8.    
  9.     h = [d1] '读取D1限制最大值h
  10.     m = h \ 10 '计算累计+10需要的最大行数m
  11.     k = UBound(ar) * (m + 1) ^ n '估计全部组合个数k
  12.     ReDim jg(k, n): k = 0 '定义存放组合结果的数组jg、并初始化记录位置k

  13.     For i1 = 1 To UBound(ar) '遍历原始数据各行
  14.         ReDim sj(m, n) '矩阵数组sj初始化
  15.         For i2 = 0 To m '各行累计+10直到限额
  16.             For j = 1 To n '各列+10处理
  17.                 If ar(i1, j) < h - 10 * i2 Then sj(i2, j) = ar(i1, j) + 10 * i2 '不超限额时+10
  18.             Next
  19.         Next
  20.         Call dgMN(1) '调用【香川多列组合】的递归算法过程
  21.     Next
  22.     [b5].Offset(, n + 1).CurrentRegion.Offset(1) = "" '清空输出区域
  23.     [b5].Offset(, n + 1).Resize(k, n + 1) = jg '输出结果
  24.     MsgBox Format(Timer - tms, "0.00s ") & k '提示程序耗时 和 结果总数k
  25. End Sub

  26. Sub dgMN(j&) '【香川多列组合】的递归算法过程
  27.     Dim i&, l&, t
  28.     For i = 0 To m '遍历数据矩阵sj各行
  29.         t = sj(i, j) '读取该位置数值t
  30.         If t = "" Then Exit For '如为空(超过限额)则退出
  31.         If t > jg(k, j - 1) Then '如比左侧数据大则有效(排除无效组合)
  32.             jg(k, j) = t '写入此数值t
  33.             If j = n Then '如已到组合最后1列(满足组合列数=n)
  34.                 jg(k, 0) = i1 '记录该组合的原始数据行序号
  35.                 k = k + 1 '组合记录位置k+1
  36.                 For l = 1 To n - 1 '复制该组合数据到下一组
  37.                     jg(k, l) = jg(k - 1, l)
  38.                 Next
  39.             Else
  40.                 Call dgMN(j + 1) '不足n列时继续深入递归去组合下1列
  41.             End If
  42.         End If
  43.     Next
  44. End Sub
复制代码
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 23:12 , Processed in 0.299671 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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