|
本帖最后由 香川群子 于 2015-9-19 23:05 编辑
代码是简单的,但这么750多万个巨量的组合,输出成了问题……一般会死机吧。
原始数据应该转置为14行6列。
行数可以任意增减,每一列中元素个数可以不同(末尾可以是任意数量的空白单元格)
- Dim sj, jg(), a(1 To 33), d, m&, n&, k&, tms#
- Sub MultiCombin() '香川多列组合
- tms = Timer
- sj = [a1].CurrentRegion '读入多行6列数据
-
- m = UBound(sj): n = UBound(sj, 2) '读取最大行数m、总列数n(=6)
-
- Set d = CreateObject("Scripting.Dictionary") '设置字典排除重复
- Open ActiveWorkbook.Path & "\Result.txt" For Output As #1 '输出组合结果到Txt文件 (输出到工作表会死机)
- k = 0: Call dgMN(1) '调用递归过程
- Close #1 '关闭Txt文件
-
- Application.StatusBar = Format(Timer - tms, "0.0s ") & d.Count & "/" & k
- MsgBox Format(Timer - tms, "0.00s ") & d.Count & "/" & k '运行结束,提醒程序耗时、排序后字典中不重复组合数 / 组内不重复组合总数
- End Sub
- Sub dgMN(j&)
- Dim i&
- For i = 1 To m '遍历各行
- t = sj(i, j): If t = "" Then Exit For '到本列末尾空白时退出
- If a(t) = "" Then '如该元素状态为空 则可以提取组合
- a(t) = t
- If j < n Then
- Call dgMN(j + 1)
- Else
- k = k + 1: s2 = WorksheetFunction.Trim(Join(a)) '提取从小到大排序的组合结果
- If Not d.Exists(s2) Then d(s2) = "": Print #1, s2 '用字典排除重复 然后输出到Txt文件
- If k Mod 10000 = 0 Then Application.StatusBar = Format(Timer - tms, "0.0s ") & d.Count & "/" & k & "..." & s
- DoEvents '每1万个组合 在状态栏上更新显示进度
- End If
- a(t) = ""
- End If
- Next
- End Sub
复制代码 |
|