VBA Excel中部分置换生成器的数组版本

我试图做一个VBA代码来安排一个n集的k元素子集到一些序列。 换句话说,我试图列出n个成员集的所有k个排列 。 例如,我们试着列出每个字符在Range("A1:C1")单元格中的所有集合{A,B,C}的2个排列 。 这里是所有的排列:

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

如果在数据input的每个字符中没有重复,则执行上述任务的以下代码可以正常工作:

 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 

虽然上面的代码在处理重复数据时并不能很好地工作,但是我正在试图通过把input数据放在数组中find所有的k-排列来提高它的性能。 以下是arrays版本中的代码:

 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'。 我希望这里有人能够帮助我解决这个问题,并且为了制作一个好的部分字谜生成器,也就是说,如果有重复的字符,它必须能够工作。 例如,让我们来testing一下列出名字中的所有字符: ANA 。 输出应该是ANAAANNAA ,但是我的代码什么也没有返回。 对于我的名字的2个排列应该是ANAANA,但是我的代码返回ANNAANNA如果有人能帮助我,我会永远感激。

最后,我发现使用数组方法获得所有k-置换的正确代码, 前提是input中没有重复的数据。 下面的代码工作正常,相当快。

 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 

PS我仍然希望这里有人提出一个更好的版本,无论是更短或更快的版本。