常用代码——排列组合

全排列

Dim N '用于增加动态数组下标
Sub perm(arr, k, m, brr()) '全排列
    'arr为需要全排列的数组。k为数组下标,m为上标，brr为存放结果的数组
    Dim i As Integer
    If k > m Then
        N = N + 1
        For i = 0 To m

            ReDim Preserve brr(1 To m + 1, 1 To N)
            brr(i + 1, N) = arr(i)
        Next i

    Else
        For i = k To m
            Call swap(arr, k, i)
            Call perm(arr, k + 1, m, brr())
            Call swap(arr, k, i)
        Next i
    End If
End Sub

Sub swap(arr, i, j) '数据交换
    Dim t: t = arr(i): arr(i) = arr(j): arr(j) = t
End Sub

Sub main()
    Dim brr()
    N = 0
    arr = Array(1, 2, 3, 4) '对arr全排列
    Call perm(arr, LBound(arr), UBound(arr), brr)
    [A1].Resize(UBound(brr, 2), UBound(brr)) = Application.Transpose(brr)
End Sub

排列

Sub test2()
    Dim i&, t#
    Dim arr(1 To 6)
    For i = 1 To 6
        arr(i) = i
    Next
    t = Timer: brr = AArr(arr, 6): [a1] = Format(Timer - t, "0.000000s")
    [b1].Resize(UBound(brr), 6) = brr
End Sub
'排列
Function AArr(ByRef sj, ByVal n&) 'sj 为一维数组，数据中任意N个元素的所有排列，返回一个二维数组
    Dim i&, j&, k&, l&, m&
    l = LBound(sj)
    m = UBound(sj)
    k = (m - l + 1) ^ n
    ReDim a(k, 1 To n)
    For j = 1 To n
        a(k, j) = l
    Next
    For i = 0 To k - 1
        For j = 1 To n
            a(i, j) = sj(a(k, j))
        Next
        For j = n To 1 Step -1
            If a(k, j) = m Then a(k, j) = l Else a(k, j) = a(k, j) + 1: Exit For
        Next
    Next
    AArr = a
End Function

组合

Sub test()
    Dim i&, t#
    Dim arr(1 To 20)
    For i = 1 To 20
        arr(i) = i
    Next
    t = Timer: brr = CArr(arr, 6): [a1] = Format(Timer - t, "0.000000s")
    [b1].Resize(UBound(brr), 6) = brr
End Sub
'组合
Function CArr(ByRef sj, ByVal n&)  'sj 为一维数组下标从1开始，数据中任意N个元素的所有组合，返回一个二维数组
    Dim i&, j&, k&, l&, m&
    ReDim a&(1 To n): For j = 1 To n - 1: a(j) = j: Next
    m = UBound(sj)
    k = Application.Combin(m, n): ReDim B$(1 To k, 1 To n)
    k = 0: i = n - 1 ': j = n
    Do
        For i = i + 1 To m
            a(j) = i
            k = k + 1:
            For l = 1 To n: B(k, l) = sj(a(l)): Next
        Next
        For j = j - 1 To 1 Step -1
            i = a(j) + 1: a(j) = i
            If i = m - n + j Then
                k = k + 1: For l = 1 To n: B(k, l) = sj(a(l)): Next
            Else
                j = j + 1
                Do Until j = n
                    i = i + 1: a(j) = i: j = j + 1
                Loop
                If i = m Then Exit Do Else Exit For
            End If
        Next
    Loop Until j = 0
    CArr = B
End Function