Excel·VBA数组排列函数

上一篇文章《Excel·VBA数组组合函数、组合求和》，实现了VBA组合功能，本文为VBA排列功能

《百度百科-排列》
排列：从n个不同元素中，取出m（m≤n）个元素，按照一定的顺序排成一列，叫做从n个元素中取出m个元素的一个排列，一般称作选排列；当m=n时，这个排列被称作全排列
排列数：从n个不同元素中取出m个不同元素的所有不同排列的个数称为排列种数或称排列数
排列个数公式：P(n,m) = n!/(n-m)!，当n=m即全排列时为P(n) = n!

1，排列代码思路

从1-5共5个数字中选出4个数字，共120种排列，如图（部分截图）

按照上一篇文章“VBA组合函数”尾数循环的方式，观察每个排列的数字排列规律，可以发现每次尾数循环结束后，倒数第2列（即m-1）即进位+1（即2-3行）；当进位列的数字达到最大值（即n）时，继续向前1列（即m-2）进位+1（即6-7行）；当进位后的数字在之前出现过时，数字继续递增+1（即8-9行）；进位结束后，排列在进位点之前的数字不变，之后的数字，按照1-5的顺序填入，且数字不重复；如此循环直至完成120种排列

VBA代码如下

2，VBA数组排列函数

选排列、全排列

Function permut_arr(arr, n&)
    'arr一维数组，内含m个元素，抽取n个进行排列，返回一维嵌套数组，每行为一个排列(数组从1开始计数)
    Dim i&, j&, k&, m&, kk&, result, x&, r&
    If LBound(arr) = 0 Then  '转为从1开始计数
        arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(arr))
    End If
    m = UBound(arr) - LBound(arr) + 1: ReDim brr&(1 To m): ReDim b&(1 To n)
    kk = Application.permut(m, n): ReDim result(1 To kk): ReDim res(1 To n)
    If n = 1 Then
        For i = 1 To m
            result(i) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Array(arr(i))))
        Next
        permut_arr = result: Exit Function
    End If
    
    For i = 1 To m  'arr初始位置brr
        brr(i) = i
    Next
    Do
        For i = 1 To n - 1  'b非尾数部分
            b(i) = brr(i)
        Next
        For j = n To m   '仅修改尾数
            b(n) = brr(j)
            For k = 1 To n
                res(k) = arr(b(k))
            Next
            r = r + 1: result(r) = res
        Next
        x = n - 1: brr(x) = brr(x) + 1  '尾数循环结束后，n-1位进位
        y = Application.Match(brr(x), brr, 0)
        Do While (TypeName(y) <> "Error" And y < x) Or brr(x) > m
            If y < x Then brr(x) = brr(x) + 1  '进位后，如之前位有重复值的继续+1
            '循环进位，直至完成所有进位
            If brr(x) > m Then If x > 1 Then x = x - 1: brr(x) = brr(x) + 1 Else Exit Do
            y = Application.Match(brr(x), brr, 0)
        Loop
        If brr(1) > m Then Exit Do  '所有排列完成
        For i = 1 To m     '对brr数组x之后的按顺序赋值
            exist = False  '初始为不存在
            For j = 1 To x
                If brr(j) = i Then exist = True: Exit For
            Next
            If exist = False And x < m Then x = x + 1: brr(x) = i
        Next
    Loop Until r = kk
    permut_arr = result
End Function

注意：代码中“排列个数”kk定义为Long类型，故最大值为2,147,483,647，如果实际应用中会超过该值的，需修改数据类型

Sub permut_arr测试()
    Dim arr, brr
    tm = Timer
    arr = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9)
    brr = permut_arr(arr, 6)
    For Each b In brr
        r = r + 1: Cells(r, "a").Resize(1, UBound(b)) = b
    Next
    Debug.Print ("所有选排列写入完成，用时：" & Format(Timer - tm, "0.00"))
'--------------------转二维数组写入
'    tm = Timer
'    arr = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9)
'    brr = TransposeArr(permut_arr(arr, 6), 2)  '调用函数，将一维嵌套数组转为二维数组
'    Cells(1, "a").Resize(UBound(brr), UBound(brr, 2)) = brr
'    Debug.Print ("所有选排列写入完成，用时：" & Format(Timer - tm, "0.00"))  '耗时
End Sub

注意：测试中调用了TransposeArr函数，将一维嵌套数组转为二维数组输出，代码详见《Excel·VBA数组组合函数、组合求和》

测试在excel表格中输出0-9共10个数字选6的排列形式，共151200种排列，输出结果与python的结果完全一致
python排列：《python排列组合函数》

3种输出排列方式耗时对比：151200种排列耗时秒数

python排列	VBA排列一维嵌套数组	VBA排列一维嵌套数组转二维数组
15.5	5.16	1.46

可以看出，VBA排列输出一维嵌套数组2种写入方式都是非常快的

3，VBA数组重复排列函数

重复排列，相比上面的“选排列”和“全排列”是一种特殊的排列
重复排列：从n个不同元素中可重复地选取m个元素，按照一定的顺序排成一列，称作从n个元素中取m个元素的可重复排列
重复排列个数公式：n ^ m
代码思路：重复排列由于元素可重复使用，因而代码思路类似“选排列”，但仅考虑进位无需判断是否重复，仅原位置重置即可，故此代码较为简单（与10进制数字进位类似）

Function permut_repet(arr, n&)
    'arr一维数组，内含m个元素，重复抽取n个进行排列，返回一维嵌套数组，每行为一个排列(数组从1开始计数)
    Dim i&, m&, kk&, result, x&, r&
    If LBound(arr) = 0 Then  '转为从1开始计数
        arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(arr))
    End If
    m = UBound(arr) - LBound(arr) + 1: ReDim b&(1 To n)
    kk = m ^ n: ReDim result(1 To kk): ReDim res(1 To n)
    
    For i = 1 To n  '临时位置，index初始值
        b(i) = 1
    Next
    Do
        For i = 1 To n
            res(i) = arr(b(i))
        Next
        r = r + 1: result(r) = res
        x = n: b(x) = b(x) + 1   '修改尾数；当尾数循环结束后，进位
        Do While b(x) > m        '进位，b中元素的最大值是m，从后向前判断
            b(x) = 1: x = x - 1  '尾数重置，进位
            If x = 0 Then Exit Do  '完成所有排列
            b(x) = b(x) + 1
        Loop
    Loop Until r = kk
    permut_repet = result
End Function

注意：代码中“排列个数”kk定义为Long类型，故最大值为2,147,483,647，如果实际应用中会超过该值的，需修改数据类型

Sub permut_repet测试()
    Dim arr, brr
    tm = Timer
    arr = Array(1, 2, 3, 4, 5)
    brr = permut_repet(arr, 3)
    For Each b In brr
        r = r + 1: Cells(r, "a").Resize(1, UBound(b)) = b
    Next
    Debug.Print ("所有重复排列写入完成，用时：" & Format(Timer - tm, "0.00"))
End Sub

从1-5共5个数字中重复选出3个数字，共125种排列，如图（部分截图）