VBA Excel中部分排列生成器的数组版本

Question

我正在尝试制作一个 VBA 代码来将 n 集的 k 元素子集排列到某个序列中。换句话说，我试图列出所有k-permutations of n 成员集。例如，让我们尝试列出所有2-permutations of set {A,B,C}，其中每个字符位于Range("A1:C1") 的单元格中。以下是所有排列：

{A,B}       {A,C}       {B,A}       {B,C}       {C,A}       {C,B}

如果数据输入的每个字符都没有重复，则执行上述任务的以下代码可以正常工作：

Sub Permutation()
Dim Data_Input As Variant, Permutation_Output As Variant
Dim Output_Row As Long, Last_Column As Long

Rows("2:" & Rows.Count).Clear
Last_Column = Cells(1, Columns.Count).End(xlToLeft).Column
Data_Input = Application.Transpose(Application.Transpose(Range("A1", Cells(1, Last_Column))))

k = InputBox("Input the value of k for P(" _
    & UBound(Data_Input) & " , k) where k is an integer between 2 and " _
    & UBound(Data_Input) & " inclusive.", "Permutation", 1)

If k >= 2 And k <= UBound(Data_Input) Then
    Output_Row = 2
    ReDim Permutation_Output(1 To k)
    Call Permutation_Generator(Data_Input, Permutation_Output, Output_Row, 1)
Else
    MsgBox "The input [" & k & "] is invalid. The input must be an integer between 2 and " _
    & UBound(Data_Input) & " inclusive."
End If

End Sub

Function Permutation_Generator(Data_Input As Variant, Permutation_Output As Variant, _
                               Output_Row As Long, Output_Index As Integer)
Dim i As Long, j As Long, P As Boolean

For i = 1 To UBound(Data_Input)
    P = True
    For j = 1 To Output_Index - 1
        If Permutation_Output(j) = Data_Input(i) Then
            P = False
            Exit For
        End If
    Next j
    If P Then
        Permutation_Output(Output_Index) = Data_Input(i)
        If Output_Index = k Then
            Output_Row = Output_Row + 1
            Range("A" & Output_Row).Resize(, k) = Permutation_Output
        Else
            Call Permutation_Generator(Data_Input, Permutation_Output, Output_Row, Output_Index + 1)
        End If
    End If
Next i
End Function

虽然上面的代码在处理重复数据方面效果不佳，但我试图通过将输入数据放入数组中并在数组中查找所有 k 排列来提高其性能。这是数组版本中的代码：

Option Explicit
Public k As Variant, Permutation_Table As Variant
Sub Permutation()
Dim Data_Input, Permutation_Output
Dim Output_Row As Long, Last_Column As Long

Rows("2:" & Rows.Count).Clear
Last_Column = Cells(1, Columns.Count).End(xlToLeft).Column
Data_Input = Application.Transpose(Application.Transpose(Range("A1", Cells(1, Last_Column))))

k = InputBox("Input the value of k for P(" _
    & UBound(Data_Input) & " , k) where k is an integer between 2 and " _
    & UBound(Data_Input) & " inclusive.", "Permutation", 1)

ReDim Permutation_Table(1 To Output_Row - 2, 1 To k)

If k >= 2 And k <= UBound(Data_Input) Then
    Output_Row = 2
    ReDim Permutation_Output(1 To k)
    Call Permutation_Generator(Data_Input, Permutation_Output, Output_Row, 1)
Else
    MsgBox "The input [" & k & "] is invalid. The input must be an integer between 2 and " _
    & UBound(Data_Input) & " inclusive."
End If
Range("A3", Cells(Output_Row - 2, k)) = Permutation_Table
End Sub

Function Permutation_Generator(Data_Input As Variant, Permutation_Output As Variant, _
                               Output_Row As Long, Output_Index As Integer)
Dim i As Long, j As Long, n As Long, P As Boolean

For i = 1 To UBound(Data_Input)
    P = True
    For j = 1 To Output_Index - 1
        If Permutation_Output(j) = Data_Input(i) Then
            P = False
            Exit For
        End If
    Next j
    If P Then
        Permutation_Output(Output_Index) = Data_Input(i)
        If Output_Index = k Then
            Output_Row = Output_Row + 1
            For n = 1 To k
            Permutation_Table(Output_Row, n) = Permutation_Output(n)
            Next n
        Else
            Call Permutation_Generator(Data_Input, Permutation_Output, Output_Row, Output_Index + 1)
        End If
    End If
Next i
End Function

不幸的是，我在尝试修复它时遇到了一些错误。我遇到的最后一个错误是运行时错误“7”。我希望这里有人可以帮助我修复它并改进它，以便制作一个好的部分字谜生成器，即如果有重复的字符，它必须能够工作。例如，让我们测试列出我名字中的所有字符：ANA。 The output 应该是 ANA、AAN 和 NAA，但我的代码什么也不返回。 2-permutations of my name 应该是 AN、AA 和 NA 但我的代码返回 AN、NA 、AN 和 NA。 如果有人能帮助我，我将永远感激不尽。

Answer 1

最后，我找到了使用数组方法获取所有 k 排列的正确代码假设输入中没有重复数据。以下代码运行良好且速度非常快。

Dim k As Long, Permutation_Table
Sub Permutation()
Dim Data_Input, Permutation_Output
Dim Output_Row As Long, Last_Column As Long, Array_Row As Long

Rows("2:" & Rows.Count).Clear
Last_Column = Cells(1, Columns.Count).End(xlToLeft).Column
Data_Input = Application.Transpose(Application.Transpose(Range("A1", Cells(1, Last_Column))))

k = InputBox("Input the value of k for P(" _
    & UBound(Data_Input) & " , k) where k is an integer between 2 and " _
    & UBound(Data_Input) & " inclusive.", "Permutation", 1)

Array_Row = WorksheetFunction.Fact(k) * WorksheetFunction.Combin(UBound(Data_Input), k)

ReDim Permutation_Table(1 To Array_Row, 1 To k)

If k >= 2 And k <= UBound(Data_Input) Then
    ReDim Permutation_Output(1 To k)
    Call Permutation_Generator(Data_Input, Permutation_Output, Output_Row, 1)
Else
    MsgBox "The input [" & k & "] is invalid. The input must be an integer between 2 and " _
    & UBound(Data_Input) & " inclusive."
End If
Range("A3").Resize(Array_Row, k) = Permutation_Table    'Use this line if UBound(Data_Input) < 10
End Sub

Function Permutation_Generator(Data_Input As Variant, Permutation_Output As Variant, _
                               Output_Row As Long, Output_Index As Integer)
Dim i As Long, j As Long, P As Boolean

For i = 1 To UBound(Data_Input)
    P = True
    For j = 1 To Output_Index - 1
        If Permutation_Output(j) = Data_Input(i) Then
            P = False
            Exit For
        End If
    Next j
    If P Then
        Permutation_Output(Output_Index) = Data_Input(i)
        If Output_Index = k Then
            Output_Row = Output_Row + 1
            For n = 1 To k
                Permutation_Table(Output_Row, n) = Permutation_Output(n)
            Next n
            Debug.Print Join(Permutation_Output, ",")    'Optional, use this line as the output if UBound(Data_Input) > 9
        Else
            Call Permutation_Generator(Data_Input, Permutation_Output, Output_Row, Output_Index + 1)
        End If
    End If
Next i
End Function

P.S.我仍然希望这里有人提出更好的版本，或者更短或更快的版本。