求助大神！相同产品组合，在不同订单中出现次数.

hope9966

求助大神！相同产品组合，在不同订单中出现次数.
VBA可以实现吗。 uuuii.rar (8.73 KB, 下载次数: 21)

2016-3-31 11:04 上传

点击文件名下载附件

蓝桥玄霜

请见代码。

hope9966

蓝桥玄霜 发表于 2016-3-31 12:36
请见代码。

十分感谢玄霜老师！
十分强大,:)

从上往下看，中间就卡住了，有个十分没看明白的地方，
if d.exists(x)=false then set d(x)=createobject("scripting.dictionary")
d(x)(y)=d(x)(y)&y&","

这句d(x)的item又新建一个字典，是这么理解吗？
哪下面d(x)(y)，这个是什么用法，
老师，有讲解的相关贴吗？
感谢玄霜老师!

hope9966

蓝桥玄霜 发表于 2016-3-31 12:36
请见代码。

感谢老师，

还有，这个结果表的E列（出现的组合），能否自动生成？

hope9966

正在下沉ing，，，，焦灼中ing ,,,,,,

hope9966

顶

顶
顶

浮力++++++++

香川群子

按单号生成各种组合，然后统计。
统计完成后，列出重复的组合。

逻辑很简单那。
关键是需要使用生成全组合的算法，然后用字典统计即可。

香川群子

字典记录、递归全组合计算。

1. Dim ar, dic, n&, i2&
   
2. Sub test() 'by kagawa 2016/4/1
   
3.     Dim i&, m&, t$, tms#
   
4.     tms = Timer
   
5.    
   
6.     Set dic = CreateObject("Scripting.Dictionary") '设置字典记录各种组合
   
7.    
   
8.     m = [a1].End(4).Row '检查数据行数
   
9.     [a1].Resize(m, 2).Sort [a2], 1, [b2], , 1, , , 1 '按单号、产品排序
   
10.     ar = [a2].Resize(m, 2) '排序后的数据读入数组ar
    
11. 
    
12.     For i = 1 To m '遍历数据各行
    
13.         t = ar(i, 1)
    
14.         For i2 = i + 1 To m '二次循环
    
15.             If ar(i2, 1) <> t Then Exit For '检查到单号不同时停止
    
16.         Next
    
17.         n = i2 - i '本单号产品个数n
    
18. 
    
19.         Call dgQZH("", i - 1, 0) '调用全组合递归算法
    
20.         i = i2 - 1 '本单处理完成后跳到下一单
    
21.     Next
    
22.    
    
23.     '字典统计完成后，整理数据
    
24.     ReDim br(1 To dic.Count, 1 To 2) '定义存放结果的数组br
    
25.     i2 = 0 '记录位置初始化
    
26. 
    
27.     kr = dic.keys '读取字典keys
    
28.     tr = dic.items '读取字典items
    
29.     For i = 0 To UBound(kr) '遍历
    
30.         If InStr(kr(i), ",") Then If tr(i) > 1 Then i2 = i2 + 1: br(i2, 1) = kr(i): br(i2, 2) = tr(i)
    
31.         '检查2个以上产品的组合、且重复数>1 然后输出
    
32.     Next
    
33.    
    
34.     [e1].CurrentRegion.Offset(1) = "" '清空输出区域
    
35.     [e2].Resize(i2, 2) = br '结果写入工作表
    
36.     MsgBox Format(Timer - tms, "0.000s ") & i2
    
37. End Sub
    
38. 
    
39. Sub dgQZH(s$, i1&, t&) '递归全组合算法、解释略
    
40.     Dim i&, s2$
    
41.     s2 = Mid(s, 2): dic(s2) = dic(s2) + 1
    
42.     For i = i1 + 1 To i2 - 1
    
43.         Call dgQZH(s & "," & ar(i, 2), i, t + 1)
    
44.     Next
    
45. End Sub

复制代码

hope9966

香川群子 发表于 2016-4-1 14:06
字典记录、递归全组合计算。

老师，强大！
感谢感谢，
今天鲜花没有了，后天补20朵，