引自挑战号称世界第一的凑数算法-Excel VBA程序开发-ExcelHome技术论坛 -王守恩坛友，
给出一个正整数n,将获得数组（0,1,1,2,2,…,n,n），
即1至n每个数字有2个，0只有一个。
排列这些数字，使得两个 k 中间有 k 个数（k=1,2,…,n)，
譬如。
1有1种排法： ("101")---两个1中间有1个数字（0）；
2有1种排法: ("12102")---1和1中间有1个数字（2），2和2之间有2个（10）
3有1种排法：("1312032")
4有3种排法：("131423024" "141302432" "240231413")
5有11种排法
我们约定：第1个数(不能是0)小于或等于最后1个数。
得到一串数：1, 1, 1, 3, 11, 38, 130, 638, 4158, 23384, 124520, 847484, 6987380,......
以下给出一个粗糙的递归解法。
但递归毕竟效率有点低，有兴趣的朋友可以试试其他算法。
Dim ar, m, r, d, br
Sub main()
t = Timer
Set d = VBA.CreateObject("scripting.dictionary")
Sheet1.UsedRange.Offset(1).ClearContents
n = Range("c1").Value '获得数字n
m = 2 * n + 1 '数组长度
r = 1
ReDim ar(1 To m) '数组ar存放结果
'ReDim br(1 To 999999, 1 To m)
Call zh(1, n) '开始递归排列
Range("i1") = r - 1
'Range("a2").Resize(r, m) = br
MsgBox Timer - t & "s"
End Sub
Sub zh(startw, n) 'startw是开始位置
If startw > m Then '位置到底末尾，输出结果
If ar(m) >= ar(1) Then
r = r + 1
Cells(r, 1).Resize(1, m) = ar
' For j = 1 To m
' br(r, j) = ar(j)
' Next
End If
Exit Sub
End If
If ar(startw) <> "" Then '如何startw位置不为空，递归下一位置
Call zh(startw + 1, n)
Exit Sub
End If
For i = IIf(startw = 1, 1, 0) To n '试填数字0-n
nextw = IIf(i = 0, startw, startw + i + 1)
If Not d.exists(i) And nextw <= m Then
If ar(nextw) = "" Then
ar(startw) = i
ar(nextw) = i
d(i) = ""
Call zh(startw + 1, n) '递归
ar(startw) = "" '回溯
ar(nextw) = ""
d.Remove i
End If
End If
Next
End Sub
排数字.zip
(20.6 KB, 下载次数: 10)
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-7-18 10:03
楼主
