基于input在Excel中生成多个单元格的排列

我试图生成Excel中单个列中包含的单词的nPr排列，其中“n”和“r”是可变的。 在下面给出的例子中，第一列包含单词，第二列包含输出。

在这种情况下，n = 3和r = 2

另一个例子，其中n = 3和r = 3：

到目前为止，我已经设法在VBA中find一个解决scheme，使用下面的方法返回combinations而不是permutations ：

 Sub Perm() Dim i As Long, j As Long, last As Long Count = 2 last = Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To last For j = i + 1 To last Cells(Count, 2).Value = Cells(i, 1).Value & "," & Cells(j, 1).Value Count = Count + 1 Next j Next i End Sub 

有了这个，我可以生成组合只有n作为variables。 r固定为2。

Answer 1

一个recursion的方法，将与任何数量的项目和任何r ：

 Function Permutations(items As Variant, r As Long, Optional delim As String = ",") As Variant 'items is a 1-based array of items 'returns all nPr permutations of items 'returns a 1-based variant array 'where each item is a delimited string 'represented the permutation 'r is assumed to be < n Dim n As Long, i As Long, j As Long, k As Long Dim rest As Variant, perms As Variant Dim item As Variant n = UBound(items) 'number of items ReDim perms(1 To Application.WorksheetFunction.Permut(n, r)) If r = 1 Then 'basis case For i = 1 To n perms(i) = items(i) Next i Else k = 1 For i = 1 To n item = items(i) ReDim rest(1 To n - 1) For j = 1 To n - 1 If j < i Then rest(j) = items(j) Else rest(j) = items(j + 1) End If Next j rest = Permutations(rest, r - 1) For j = 1 To UBound(rest) perms(k) = item & delim & rest(j) k = k + 1 Next j Next i End If Permutations = perms End Function Sub test() Dim i As Long, n As Long Dim items As Variant n = Cells(Rows.Count, 1).End(xlUp).Row ReDim items(1 To n) For i = 1 To n items(i) = Cells(i, 1).Value Next i items = Permutations(items, 3) For i = 1 To UBound(items) Cells(i, 2).Value = items(i) Next i End Sub 

例如：

一路下降到：

（注意210 = 7P3）。

Answer 2

有趣的问题。 我用一个子和函数的组合来解决这个问题，它产生了下一个级别，包括一个选项来获得列中的所有排列级别：

 Option Explicit Const Delimiter As String = ", " Private Base As Variant Sub Permutations(Inp As Range, Nbr As Integer, OutpStart As Range, Optional All As Boolean = False) Dim Arr Dim Perm As Integer Base = Inp.Value2 Arr = Inp.Value2 For Perm = 2 To Nbr Arr = NextPermLvl(Arr) Next Perm OutpStart.Resize(UBound(Arr), 1).Value = IIf(Nbr = 1, Arr, (Application.Transpose(Arr))) End Sub Private Function NextPermLvl(ByVal Arr) As Variant Dim OutArr() As String: ReDim OutArr(1 To 100000) Dim OldVal, OldValArr, exst As Boolean, counter As Long Dim BaseVal, BaseInOldVal For Each OldVal In Arr OldValArr = Split(OldVal, Delimiter) For Each BaseVal In Base exst = False For Each BaseInOldVal In OldValArr If BaseInOldVal = BaseVal Then exst = True: Exit For Next BaseInOldVal If Not exst Then counter = counter + 1 OutArr(counter) = OldVal & Delimiter & BaseVal End If Next BaseVal Next OldVal ReDim Preserve OutArr(1 To counter) NextPermLvl = OutArr End Function Sub Test() Range("G2:G100000").ClearContents Permutations Range("A2:A5"), 3, Range("G2") End Sub