列出最多 13 個數字或文字的排列

Emily

以下的編碼可列出最多 13 個數字或文字的排列 (Permutations)

Sub PermutationsFromRange() Dim DestRange As Object Dim PermString As Variant Dim NewPerm As String Dim SepChar As String Dim NumOfElements As Integer Dim NumOfPerm As Double Dim Factorial(1 To 13) Dim Counter1 As Long Dim Counter2 As Long Dim Rotate As Integer Dim Dummy

' 最多 13 個元素

PermString = Range("A1:A3") SepChar = ","

NumOfElements = UBound(PermString) NumOfPerm = Application.Fact(NumOfElements) For Counter1 = 1 To NumOfElements Factorial(Counter1) = Application.Fact(NumOfElements - Counter1) Next Counter1

Worksheets.Add Set DestRange = Range("a1")

For Counter1 = 1 To NumOfElements NewPerm = NewPerm & PermString(Counter1, 1) & SepChar Next Counter1 DestRange.Value = Left(NewPerm, Len(NewPerm) - Len(SepChar)) For Counter1 = 2 To NumOfPerm NewPerm = "" If Counter1 / 2 = Int(Counter1 / 2) Then Rotate = NumOfElements - 1 Else For Counter2 = 1 To NumOfElements - 2 If Counter1 Mod Factorial(Counter2) = 1 Then Rotate = Counter2 Exit For End If Next Counter2 End If For Counter2 = 1 To Int((NumOfElements - Rotate + 1) / 2) Dummy = PermString(Rotate + Counter2 - 1, 1) PermString(Rotate + Counter2 - 1, 1) = PermString(NumOfElements - Counter2 + 1, 1) PermString(NumOfElements - Counter2 + 1, 1) = Dummy Next Counter2 For Counter2 = 1 To NumOfElements NewPerm = NewPerm & PermString(Counter2, 1) & SepChar Next Counter2 DestRange.Offset(Counter1 - 1) = Left(NewPerm, Len(NewPerm) - Len(SepChar)) Next Counter1 Set DestRange = Nothing End Sub

EUfbkR3W.zip (8.46 KB, 下载次数: 97)

2004-11-20 13:00 上传

点击文件名下载附件
列出最多 13 個數字或文字的排列 (Permutations)

[此贴子已经被作者于2004-12-22 14:01:28编辑过]

Emily

以下是字串方式

Sub PermutationsFromString() Dim DestRange As Object Dim PermString As String Dim LenPermString As Integer Dim NumOfPerm As Double Dim Factorial(1 To 13) Dim Counter1 As Long Dim Counter2 As Long Dim Rotate As Integer Dim Dummy

' 最多 13 個元素 PermString = "123ABC"

LenPermString = Len(PermString) NumOfPerm = Application.Fact(LenPermString) For Counter1 = 1 To LenPermString Factorial(Counter1) = Application.Fact(LenPermString - Counter1) Next Counter1

Worksheets.Add Set DestRange = Range("a1")

DestRange.Value = PermString For Counter1 = 2 To NumOfPerm If Counter1 / 2 = Int(Counter1 / 2) Then Rotate = LenPermString - 1 Else For Counter2 = 1 To LenPermString - 2 If Counter1 Mod Factorial(Counter2) = 1 Then Rotate = Counter2 Exit For End If Next Counter2 End If For Counter2 = 1 To Int((LenPermString - Rotate + 1) / 2) Dummy = Mid$(PermString, Rotate + Counter2 - 1, 1) Mid$(PermString, Rotate + Counter2 - 1, 1) = Mid$(PermString, Len(PermString) - Counter2 + 1, 1) Mid$(PermString, LenPermString - Counter2 + 1, 1) = Dummy Next Counter2 DestRange.Offset(Counter1 - 1) = PermString Next Counter1 Set DestRange = Nothing End Sub

Emily

以下是字串方式 Combination

Sub CombinationsFromString() Dim DestRange As Object Dim CountOff() Dim MaxOff() Dim CombString As String Dim NewComb As String Dim NumOfComb As Long Dim Dummy Dim SubSet As Long Dim LenCombString As Long Dim Counter1 As Long Dim Counter2 As Long

CombString = "1234567890" ' Or Cells(1,1) ' 最多 13 個元素 SubSet = 5

LenCombString = Len(CombString) NumOfComb = Application.Combin(LenCombString, SubSet)

ReDim CountOff(SubSet) ReDim MaxOff(SubSet)

For Counter1 = 1 To SubSet CountOff(Counter1) = Counter1 MaxOff(Counter1) = LenCombString - SubSet + Counter1 Next Counter1

Worksheets.Add Set DestRange = Range("a1")

For Counter1 = 1 To NumOfComb NewComb = "" For Counter2 = 1 To SubSet NewComb = NewComb & Mid$(CombString, CountOff(Counter2), 1) Next Counter2 DestRange.Offset(Counter1 - 1) = NewComb CountOff(SubSet) = CountOff(SubSet) + 1 Dummy = SubSet While Dummy > 1 If CountOff(Dummy) > MaxOff(Dummy) Then CountOff(Dummy - 1) = CountOff(Dummy - 1) + 1 For Counter2 = Dummy To SubSet CountOff(Counter2) = CountOff(Counter2 - 1) + 1 Next Counter2 End If Dummy = Dummy - 1 Wend Next Counter1 End Sub

Long_III

先收藏，谢谢了！

我慢慢看！

hhzjxss

谢谢了，先看看！

cjch1969

用函数可以解决吗？