我有一个10个单词的列表，需要创建一个包含这些单词所有不同排列的数组，即[[1,2,3,4]，[1,2,4,3]，[1， 4,2,3]，...]。
我设法通过Javascript使它工作，但是我真的在VBA方面苦苦挣扎。
function perm(xs) {
let ret = [];
for (let i = 0; i < xs.length; i = i + 1) {
let rest = perm(xs.slice(0, i).concat(xs.slice(i + 1)));
if (!rest.length) {
ret.push([xs[i]])
} else {
for (let j = 0; j < rest.length; j = j + 1) {
ret.push([xs[i]].concat(rest[j]))
}
}
}
return ret;
}
答案 0 :(得分：1)
没有重复并且总是选择4个单词
Option Explicit
Public Sub Permutations()
Dim Words() As Variant
Words = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
Dim p1 As Long, p2 As Long, p3 As Long, p4 As Long
For p1 = LBound(Words) To UBound(Words)
For p2 = LBound(Words) To UBound(Words)
If p2 <> p1 Then
For p3 = LBound(Words) To UBound(Words)
If p3 <> p1 And p3 <> p2 Then
For p4 = LBound(Words) To UBound(Words)
If p4 <> p1 And p4 <> p2 And p4 <> p3 Then
Debug.Print Words(p1); Words(p2); Words(p3); Words(p4)
End If
Next p4
End If
Next p3
End If
Next p2
Next p1
End Sub
输出将类似于
1 2 3 4
1 2 3 5
1 2 3 6
1 2 3 7
1 2 3 8
1 2 3 9
1 2 3 10
1 2 4 3
1 2 4 5
1 2 4 6
1 2 4 7
1 2 4 8
…
10 9 8 7
或者编写一个回归函数。
将所有内容放入数组
Option Explicit
Public Sub PermutationsToArray()
Dim Words() As Variant
Words = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
Dim WordsCount As Long
WordsCount = UBound(Words) - LBound(Words) + 1
Dim OutputCount As Long
OutputCount = WordsCount * (WordsCount - 1) * (WordsCount - 2) * (WordsCount - 3)
ReDim OutputArray(0 To OutputCount - 1, 0 To 3) As Variant
Dim iCount As Long
Dim p1 As Long, p2 As Long, p3 As Long, p4 As Long
For p1 = LBound(Words) To UBound(Words)
For p2 = LBound(Words) To UBound(Words)
If p2 <> p1 Then
For p3 = LBound(Words) To UBound(Words)
If p3 <> p1 And p3 <> p2 Then
For p4 = LBound(Words) To UBound(Words)
If p4 <> p1 And p4 <> p2 And p4 <> p3 Then
OutputArray(iCount, 0) = Words(p1)
OutputArray(iCount, 1) = Words(p2)
OutputArray(iCount, 2) = Words(p3)
OutputArray(iCount, 3) = Words(p4)
iCount = iCount + 1
End If
Next p4
End If
Next p3
End If
Next p2
Next p1
End Sub
答案 1 :(得分：1)
Pᴇʜ和Tragamor都将您的问题解释为对四个单词的所有排列的要求。我将您的问题解释为要求对所有10个单词进行排列。他们的答案与他们的解释相符。这个答案与我的解释相符，尽管它应该返回任意数量的单词的所有排列。我已经对创建3到9个单词的所有排列的例程进行了全面测试。对于十个或更多的单词，我的测试例程需要很长时间才能生效。由于我的常规程序最多可以包含9个单词，因此我认为它适用于较大的数字。
Pᴇʜ和Tragamor都使用了递归。我认为递归是一种非常有用的技术，但对于VBA，如果不是其他语言，则它是一种缓慢的技术。我决定不进行递归。
使用我的技术，Permutation例程有两个参数：Word数组（包含十个单词）和Permutations数组（返回3,628,800个排列）。该例程具有一个数组PermCrnt，其中包含十个单词的索引。如果单词的下界为0，则PermCrnt的初始值为：
0 1 2 3 4 5 6 7 8 9
置换例程的主循环使用PermCrnt的索引将当前置换输出到数组置换，然后将PermCrnt重置为下一个序列。该循环将继续进行，直到数组“ Permutations”已满。
重置PermCrnt的代码从右侧查找不按升序排列的两个索引。这些索引以及所有右边的索引都将从PermCrnt中删除。删除的最左边的索引将依次替换为下一个。其余索引按升序排列。这给出了：
First pair not in ascending sequence. Remove that
PermCrnt pair and all to their right and re-sequence them.
0 1 2 3 4 5 6 7 8 9 “8 9”
0 1 2 3 4 5 6 7 9 8 “7 9”
0 1 2 3 4 5 6 8 7 9 “7 9”
0 1 2 3 4 5 6 8 9 7 “8 9”
0 1 2 3 4 5 6 9 7 8 “7 8”
0 1 2 3 4 5 6 9 8 7 “6 9”
0 1 2 3 4 5 7 6 8 9 “8 9”
0 1 2 3 4 5 7 6 9 8
可以看出，这种简单的算法会循环遍历所有可能的排列，直到：
9 8 7 6 5 4 3 2 1 0
对于10个单词，我的例程需要大约12秒才能生成3,628,800个排列。
我的例程，其测试如下。注意：由于我测试PermWords的方式，Words成为Variant很方便。您可能希望更改为字符串数组。
Option Explicit
Sub CallPermutations()
Dim ColOutCrnt As Long
Dim Duration As Single
Dim InxPerm As Long
Dim InxWord As Long
Dim Match As Boolean
Dim MultiWords As Variant
Dim NumWords As Long
Dim NumPerms As Long
Dim Permutations() As String
Dim RowOutCrnt1 As Long
Dim RowOutCrnt2 As Long
Dim RowOutMax As Long
Dim TimeStart As Single
Dim Words As Variant
Application.ScreenUpdating = False
MultiWords = VBA.Array(VBA.Array("apple", "bear", "cat"), _
VBA.Array("apple", "bear", "cat", "dog"), _
VBA.Array("apple", "bear", "cat", "dog", "egg"), _
VBA.Array("apple", "bear", "cat", "dog", "egg", "fast"), _
VBA.Array("apple", "bear", "cat", "dog", "egg", "fast", _
"game"), _
VBA.Array("apple", "bear", "cat", "dog", "egg", "fast", _
"game", "house"), _
VBA.Array("apple", "bear", "cat", "dog", "egg", "fast", _
"game", "house", "island"), _
VBA.Array("apple", "bear", "cat", "dog", "egg", "fast", _
"game", "house", "island", "joy"))
For Each Words In MultiWords
TimeStart = Timer
Call PermWords(Words, Permutations)
Duration = Timer - TimeStart
NumWords = UBound(Words) - LBound(Words) + 1
NumPerms = UBound(Permutations, 1) - LBound(Permutations, 1) + 1
Debug.Print "Generating " & PadL(NumPerms, 7) & _
" permutations of " & PadL(NumWords, 2) & _
" words took " & PadL(Format(Duration, "#,##0.000"), 9) & " seconds"
If NumWords < 9 Then
TimeStart = Timer
For RowOutCrnt1 = LBound(Permutations, 1) To UBound(Permutations, 1) - 1
For RowOutCrnt2 = RowOutCrnt1 + 1 To UBound(Permutations, 1)
Match = True
For ColOutCrnt = 1 To NumWords
If Permutations(RowOutCrnt1, ColOutCrnt) <> _
Permutations(RowOutCrnt2, ColOutCrnt) Then
Match = False
Exit For
End If
Next
If Match Then
Debug.Print
Debug.Print "Row " & RowOutCrnt1 & " = " & "Row " & RowOutCrnt2
Debug.Assert False
Else
End If
Next
Next
Duration = Timer - TimeStart
Debug.Print "Testing " & PadL(NumPerms, 7) & _
" permutations of " & PadL(NumWords, 2) & _
" words took " & PadL(Format(Duration, "#,##0.000"), 9) & " seconds"
End If
DoEvents
Next
End Sub
Sub PermWords(ByRef Words As Variant, ByRef Permutations() As String)
' On entry Words is a list of words created by Array, VBA.Array or
' by code that emulated Array or VBA.Array.
' On exit, Permutations will contain one row permutation of the words.
' Note: Array creates an array with a lower bound of zero or one depending
' on the Option Base statement while VBA.Array creates an array with a
' lower bound that is always zero.
' Permutations will be redim'ed as a two-dimensional array. The first
' dimension will have bounds of one to number-of-permutations. The second
' dimension will have bounds to match those of Words.
' If Words contains "one", "two" and "three", Permutations will contain:
' "one" "two" "three"
' "one" "three" "two"
' "two" "one" "three"
' "two" "three" "one"
' "three" "one" "two"
' "three" "two" "one"
Dim InxPermCrnt As Long
Dim InxToPlaceCrnt As Long
Dim InxToPlaceMax As Long
Dim InxToPlaceNext As Long
Dim InxWord As Long
Dim ValueNext As Long
Dim NumPerms As Long
Dim NumWords As Long
Dim PermCrnt() As Long
Dim RowPerms As Long
Dim ToPlace() As Long
' Calculate number of words and number of permutations
NumWords = UBound(Words) - LBound(Words) + 1
NumPerms = Factorial(NumWords)
' Redim arrays to required size
ReDim PermCrnt(LBound(Words) To UBound(Words))
ReDim Permutations(1 To NumPerms, LBound(Words) To UBound(Words))
ReDim ToPlace(1 To NumWords)
RowPerms = 1 ' First row in Permutations
' Create initial sequence of words
For InxWord = LBound(Words) To UBound(Words)
PermCrnt(InxWord) = InxWord
Next
' Loop until Permutations() is full
Do While True
' Output current permutation to Permutations
For InxPermCrnt = LBound(PermCrnt) To UBound(PermCrnt)
InxWord = PermCrnt(InxPermCrnt)
Permutations(RowPerms, InxPermCrnt) = Words(InxWord)
Next
RowPerms = RowPerms + 1
If RowPerms > UBound(Permutations, 1) Then
' All permutations generated
Exit Sub
End If
' Generate next sequence
' Find first pair from right not in ascending sequence
' Copy this pair, and all to its right, to ToPlace()
InxToPlaceMax = 1
ToPlace(InxToPlaceMax) = PermCrnt(UBound(PermCrnt))
For InxPermCrnt = UBound(PermCrnt) - 1 To LBound(PermCrnt) Step -1
InxToPlaceMax = InxToPlaceMax + 1
ToPlace(InxToPlaceMax) = PermCrnt(InxPermCrnt)
If PermCrnt(InxPermCrnt) < PermCrnt(InxPermCrnt + 1) Then
Exit For
End If
Next
' Elements InxPermCrnt to UBound(PermCrnt) of PermCrnt are to be
' resequenced. PermCrnt(InxPermCrnt) will reference the next to place word
' in sequence. Remaining elements will be the values from ToPlace() in
' ascending sequence.
' Find next value above value in PermCrnt(InxPermCrnt)
ValueNext = -1
InxToPlaceNext = -1
For InxToPlaceCrnt = 1 To InxToPlaceMax
If PermCrnt(InxPermCrnt) < ToPlace(InxToPlaceCrnt) Then
' ToPlace(InxToPlaceCrnt) is greater than PermCrnt(InxPermCrnt). It will
' be the next in sequence unless there is PermCrnt(X) such that
' PermCrnt(InxPermCrnt) < PermCrnt(X) < ToPlace(InxToPlaceCrnt)
If InxToPlaceNext = -1 Then
' This is the first ToPlace entry found that is greater than
' PermCrnt(InxPermCrnt)
ValueNext = ToPlace(InxToPlaceCrnt)
InxToPlaceNext = InxToPlaceCrnt
Else
' This is not the first ToPlace value greater than PermCrnt(InxPermCrnt)
If ValueNext > ToPlace(InxToPlaceCrnt) Then
ValueNext = ToPlace(InxToPlaceCrnt)
InxToPlaceNext = InxToPlaceCrnt
End If
End If
End If
Next
' If stop here, next value in sequence not found
Debug.Assert ValueNext <> PermCrnt(InxPermCrnt)
' Place next value in PermCrnt() and remove from ToPlace()
PermCrnt(InxPermCrnt) = ValueNext
ToPlace(InxToPlaceNext) = ToPlace(InxToPlaceMax)
InxToPlaceMax = InxToPlaceMax - 1
' Move remaining values in ToPlace() to PermCrnt() in ascending sequence
Do While InxToPlaceMax > 0
InxPermCrnt = InxPermCrnt + 1 ' Next position within PermCrnt
' Find next value to place
ValueNext = ToPlace(1)
InxToPlaceNext = 1
For InxToPlaceCrnt = 2 To InxToPlaceMax
If ValueNext > ToPlace(InxToPlaceCrnt) Then
ValueNext = ToPlace(InxToPlaceCrnt)
InxToPlaceNext = InxToPlaceCrnt
End If
Next
' Place next value in PermCrnt() and remove from ToPlace()
PermCrnt(InxPermCrnt) = ValueNext
ToPlace(InxToPlaceNext) = ToPlace(InxToPlaceMax)
InxToPlaceMax = InxToPlaceMax - 1
Loop ' until all values in ToPlace() copied to PermCrnt()
Loop ' until Permutations() is full
End Sub
Function Factorial(ByVal Num As Long)
' Return Fsctorial Num
' 6Jun19 Coded
Dim Answer As Long
Dim I As Long
Answer = 1
For I = 1 To Num
Answer = Answer * I
Next I
Factorial = Answer
End Function
Public Function PadL(ByVal Str As String, ByVal PadLen As Long, _
Optional ByVal PadChr As String = " ") As String
' Pad Str with leading PadChr to give a total length of PadLen
' If the length of Str exceeds PadLen, Str will not be truncated
' Sep15 Coded
' 20Dec15 Added code so overlength strings are not truncated
' 10Jun16 Added PadChr so could pad with characters other than space
If Len(Str) >= PadLen Then
' Do not truncate over length strings
PadL = Str
Else
PadL = Right$(String(PadLen, PadChr) & Str, PadLen)
End If
End Function
Public Function PadR(ByVal Str As String, ByVal PadLen As Long, _
Optional ByVal PadChr As String = " ") As String
' Pad Str with trailing PadChr to give a total length of PadLen
' If the length of Str exceeds PadLen, Str will not be truncated
' Nov15 Coded
' 15Sep16 Added PadChr so could pad with characters other than space
If Len(Str) >= PadLen Then
' Do not truncate over length strings
PadR = Str
Else
PadR = Left$(Str & String(PadLen, PadChr), PadLen)
End If
End Function
答案 2 :(得分：0)
我发现使用数组可能有点尴尬，因此此递归算法使用生成的字符掩码作为置换计算的输入，然后将相关项从源数组复制到输出数组中。
您可能会创建一个字符映射的一维数组，如果遇到大数组数据问题，则可以使用它来替代二维数组。
计算和加载数组的时间为10个单词：12.62秒
Dim StartTime As Single
Sub TestMain()
StartTime = Timer
Dim InArr() As Variant, OutArr() As Variant
InArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J")
Dim i As Long, j As Long, xStr As String
i = UBound(InArr) - LBound(InArr)
ReDim OutArr(i, Fact(i + 1) - 1)
For i = 0 To UBound(InArr) - LBound(InArr)
xStr = xStr & Chr(i + 65)
Next i
Call GetPermutations(InArr, OutArr, xStr)
Debug.Print Timer - StartTime
Exit Sub
' Readout
For j = 0 To UBound(OutArr, 2)
xStr = ""
For i = 0 To UBound(OutArr, 1)
xStr = xStr & OutArr(i, j)
Next i
Debug.Print xStr
Next j
End Sub
Function GetPermutations(ByRef InArr() As Variant, ByRef OutArr() As Variant, S2 As String, Optional S1 As String, Optional xRow As Long)
If IsMissing(S1) Then S1 = ""
If IsMissing(xRow) Then xRow = 0
If Len(S2) < 2 Then
' "S1 & S2" would be the character map for this iteration
Call LoadArray(InArr, OutArr, S1 & S2, xRow)
xRow = xRow + 1
Else
Dim i As Integer: For i = 1 To Len(S2)
Call GetPermutations(InArr, OutArr, Left(S2, i - 1) + Right(S2, Len(S2) - i), S1 + Mid(S2, i, 1), xRow)
Next i
End If
End Function
Function LoadArray(ByRef InArr() As Variant, ByRef OutArr() As Variant, Order As String, xRow As Long)
Dim i As Integer: For i = 1 To Len(Order)
OutArr(i - 1, xRow) = InArr(Asc(Mid(Order, i, 1)) - 65)
Next i
End Function
Function Fact(i As Integer) As Long
Fact = 1: For j = 1 To i: Fact = Fact * j: Next j
End Function