[已解决]枚举不重复排列的问题，我的方法效率低，求指点

hyqzzs · 发表于 2012-10-30 15:38

如图，A列给出任意字母，在D列将所有排列（不是组合）列举出来，所有字母全用上。我的方法在计算7个字母时，就达到5分钟了，请教高手，如何提高速度。代码如下：

Option Explicit
Dim h As Long
Dim arr() As String, brr()
Dim x As Long, z As Long, k As Long, w As Long
Dim m As Long, n As Long, j As Long
Dim dic
Sub 排列改进()
Dim t
Dim y As Long
t = Timer '计时
Set dic = CreateObject("Scripting.Dictionary")
m = Range("a65536").End(xlUp).Row '判断元素个数
ReDim arr(1 To m * m) '数组重复生成m边，放入arr
For x = 1 To m * m
y = x Mod m
If y = 0 Then
arr(x) = Cells(m, 1)
Else
arr(x) = Range("a" & y)
End If
Next x
w = 0 '用于减少递归次数
pailie "", 1 '递归
Range("d1").Resize(dic.Count) = Application.Transpose(dic.Keys)
Range("b2") = "用时" & Timer - t & "秒"
Range("b3") = "共" & dic.Count & "种排列"
Erase arr, dic
End Sub
Function pailie(sr, n)
If w < m Then '判断是否执行递归
If Len(sr) = m Then '符合长度则执行语句
If Len(Replace(sr, arr(m), "")) = 0 Then '如果sr均为最后一个元素，则往下不需执行
w = m
Exit Function
Else
For x = 1 To m '根据长度变化判断重复值
k = Len(sr)
h = Len(Replace(sr, arr(x), ""))
j = k - h
If j <> 1 Then '判断sr中是否有元素遗漏或重复
Exit Function
ElseIf x = m Then '循环是否到最后一个元素
dic(sr) = ""
Exit Function '存入字典，去重复值
End If
Next x
End If
End If
If n > m * m Then '递归
Exit Function
Else
pailie sr & arr(n), n + 1
pailie sr, n + 1
End If
End If
End Function

复制代码

最佳答案

月排行榜 / 总排行榜

香川群子

2012-10-31 20:43

补上附件。

楼主你自己写的代码只能全部扔掉，完全没有实用性。

运行起来速度慢的惨不忍睹。

跳转到最佳答案楼层

香川群子 · 发表于 2012-10-31 17:11

本帖最后由香川群子于 2012-10-31 20:52 编辑

递归和循环都可以……

其实循环比递归效率更高一些，但是代码会比较复杂。

所以递归代码会好一点。

我的代码计算运行时间是0.1秒。（不含写入单元格）
而如果是用数组循环，则计算时间只要0.06秒。比你的代码快了几千倍吧？

楼主你好好消化消化吧……我是排列组合方面的专家。

Dim sj, jg(), m%, n%, k
Sub kagawa_Permut()
tms = Timer
m = [a1].End(4).Row
sj = [a1].Resize(m)
n = [b1]
If n = 0 Or n > m Then n = m
AP = WorksheetFunction.Permut(m, n)
ReDim jg(AP, n)
k = 0
Call dgPL("", 0)
MsgBox Format(Timer - tms, "0.000s")
[b3] = AP
If k < 65536 Then [d1].CurrentRegion = "": [d1].Resize(AP, n + 1) = jg
End Sub
Sub dgPL(s, t)
If t = n Then
p = Split(s, ",")
For j = 1 To n
' jg(k, j) = sj(p(j), 1)
' jg(k, 0) = jg(k, 0) & "," & sj(p(j), 1)
jg(k, 0) = jg(k, 0) & sj(p(j), 1)
Next
' jg(k, 0) = Mid(jg(k, 0), 2)
k = k + 1
Exit Sub
End If
For j = 1 To m
If InStr(s & ",", "," & j & ",") = 0 Then Call dgPL(s & "," & j, t + 1)
Next j
End Sub

复制代码

香川群子 · 发表于 2012-10-31 17:12

如果原始数据中本身有重复，然后需要不重复的排列结果……这种情形会更加复杂。

香川群子 · 发表于 2012-10-31 17:13

如果原始数据中本身有重复，然后需要不重复的排列结果……这种情形会更加复杂。

香川群子 · 发表于 2012-10-31 17:15

在A1开始的列中输入要排列的原始数据。
在B1单元格中可以输入n=1~m之间的数值。（如果B1不输入为空，则作n=m处理。）
按下按钮，即可得到任意Permut(m,n)的全部排列结果。

香川群子 · 发表于 2012-10-31 20:43

补上附件。

楼主你自己写的代码只能全部扔掉，完全没有实用性。

运行起来速度慢的惨不忍睹。

香川群子 · 发表于 2012-10-31 20:46

根本性错误在于算法设计有误。

生成全部m*m种组合，然后逐个字母检查是否有重复、遗漏，是很愚蠢的做法。

应该在进入递归之前就进行检查，重复的事先就pass、跳过。

香川群子 · 发表于 2012-10-31 20:54

另外，如果算法正确，是不需要用字典方法来排除重复的……因为好的算法不产生重复。

rebornxldeng · 发表于 2012-11-1 11:07

膜拜下高手... ...{:081:}又被打击了

hyqzzs · 发表于 2012-11-2 18:29

真的被打击了

谢谢指点，认真学习中

		自动登录	找回密码
密码			注册

[已解决]枚举不重复排列的问题，我的方法效率低，求指点

相关帖子

评分

评分