芙蓉面姐炮轰小沈阳:Excel 排列组合之最优算法

排列组合之最优算法

任意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

非递归排列组合的原理是地址搬移.

        For i = 1 To z
            If arr1(i + 1) - arr1(i) > 1 Then Exit For      找出后一位比当前位,大于1的数.并退出
        Next i

        arr1(i) = arr1(i) + 1                               当前位加1
        arr2(i) = arr2(i + 1) & " " & arr(arr1(i), 1)

        For j = i - 1 To 1 Step -1
            arr1(j) = j                                     后面的按位置号由大到小排序.......第四位4,第三位3,第二位2,第一位1.
            arr2(j) = arr2(j + 1) & " " & arr(j, 1)
        Next j

1000\5\4\3\2\1    程序从右向左找出后一位比当前位,大于1的数.即第六位的1000-1>5,当前位加5+1变成6,后面的按位置号由大到小排序.第四位4,第三位3,第二位2,第一位1.

1000\6\4\3\2\1    

1000\6\5\3\2\1

1000\6\5\4\2\1

1000\6\5\4\3\1

1000\6\5\4\3\2

递归算法的法则是太极原理,一生二,二生四,四生八,八生十六

Sub xi(a, arr, x As Long, y As Long, z As Long, jj As Long)
    Call xi(a & " " & arr(x, 1), arr, x + 1, y + 1, z, jj)  '相当于1

    Call xi(a, arr, x + 1, y, z, jj)    '相当于0
End Sub

                                     1,                                                   0

                         1                      0                             1                0

               1             0              1        0                 1        0     1        0

递归是需要有退出程序的要不然就没完没了了   If x = UBound(arr) + 1 Then Exit Sub

 为了提高效率还得剪枝,即减少一些无用功,即前面0太多了,后面未计算的个数加上前面的已组合的个数都不足已最终组成需要的数量  If y + UBound(arr) - x + 1 < z Then Exit Sub

    If y = z Then             已满足Z个数的组合后打印结果并结果递归.
        jj = jj + 1
        Print #1, a
        Exit Sub
    End If

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