任意M个数字,对它们进行N个数的排列组合,并全部显示出来.COMBIN(M,N) 星期天白天睡多了,搞得我晚上失眠,无聊之中冒出以下排列组合的算法. 一般算法 Sub pengxi() aa = Timer Dim x% Dim i% Dim j% Dim jj As Long a = [A65536].End(xlUp).Row + 1 arr = Range("A1:A" & a) z = Cells(1, 2) ReDim arr1(1 To z + 1) As Long '存地址 ReDim arr2(1 To z + 1) '存组合 Open "d:\peng.txt" For Output As #1 For i = z To 1 Step -1 '初始化 arr1(i) = i arr2(i) = arr2(i + 1) & " " & arr(i, 1) Next i arr1(z + 1) = 1000 Do jj = jj + 1 '输出结果 Print #1, arr2(1) For i = 1 To z If arr1(i + 1) - arr1(i) > 1 Then Exit For Next i arr1(i) = arr1(i) + 1 arr2(i) = arr2(i + 1) & " " & arr(arr1(i), 1) For j = i - 1 To 1 Step -1 arr1(j) = j arr2(j) = arr2(j + 1) & " " & arr(j, 1) Next j Loop While arr1(z) < a Close #1 MsgBox "找到 " & jj & " 个解! 花费" & Format(Timer - aa, "0.00" & "保存在D:\peng.txt") & "秒" End Sub 递归算法 Sub peng() aa = Timer Dim jj As Long, cc As Long Open "d:\peng.txt" For Output As #1 arr = Range("A1:A" & [A65536].End(xlUp).Row) Call xi("", arr, 1, 0, Cells(1, 2), jj) Close #1 MsgBox "找到 " & jj & " 个解! 花费" & Format(Timer - aa, "0.00" & "保存在D:\peng.txt") & "秒" End Sub Sub xi(a, arr, x As Long, y As Long, z As Long, jj As Long) If y = z Then jj = jj + 1 Print #1, a Exit Sub End If If x = UBound(arr) + 1 Then Exit Sub If y + UBound(arr) - x + 1 < z Then Exit Sub Call xi(a & " " & arr(x, 1), arr, x + 1, y + 1, z, jj) '字附串和数字的处理速度是相差很大的 Call xi(a, arr, x + 1, y, z, jj) End Sub
LrTBjr9k.rar
(10.65 KB, 下载次数: 2169)
[此贴子已经被作者于2007-11-12 16:39:48编辑过] |