Visual Basic 排列組合

Question

有一個數列為 1,2,3,4
如何用VB語言 有效率的產生所有的排列組合呢？
並且將數列一一列印出來
例如:
1,2,3,4
1,2,4,3
1,3,2,4
1,3,4,2
1,4,2,3
1,4,3,2
2,1,3,4
.............
.............
共 4! = 24種 排列組合方法
越簡短越好

Answer 1

簡短又一目了然的方法:Private Sub Command1_Click() Cls s = 0 For i = 1 To 4  For j = 1 To 4   For k = 1 To 4    For l = 1 To 4     If i <> j And j <> k And k <> l And l <> i And i <> k And j <> l Then Print i & j & k & l: s = s + 1    Next l, k, j, i Print "共 " & s & "種 排列組合方法"End Sub(已經不大簡短...>.<")有效率...但很難解釋的方法:Dim s As Long, s1 As String, n As LongDim s2 As New CollectionPrivate Sub Form_Load()    Dim strA() As String    txt = InputBox("")    If StrPtr(txt) = 0 Then End    n = Len(txt)    ReDim strA(n) As String    For C = 1 To n: strA(C) = Mid(txt, C, 1): Next    s1 = "": s = 0: P strA, n: MsgBox s1 & "所有排列共" & s & "種組合"    If s2.Count <> s Then     s1 = ""     For i = 1 To s2.Count: s1 = s1 & Right(s2.Item(i), Len(s2.Item(i)) - 1) & vbCrLf: Next i     MsgBox s1 & "剔除重複後剩" & s2.Count & "種組合"    End If    EndEnd SubSub P(strA, IC) On Error Resume Next If IC = 1 Then  s1 = s1 & Join(strA, "") & vbCrLf: s = s + 1: s2.Add "a" & Join(strA, ""), "k" & Join(strA, "") Else  For i = 1 To IC   swtmp = strA(i): strA(i) = strA(IC): strA(IC) = swtmp   P strA, IC - 1   strTemp = strA(IC): strA(IC) = strA(i): strA(i) = strTemp  Next i End IfEnd Sub'輸入 1234
圖片參考：http://homelf.kimo.com.tw/gamble_chen/test/p_arr_4.gif

Answer 2

天啊~~不過是個排列組合, 竟然可以討論得這麼熱烈???
話說回來, 編輯功能是什麼??? 阿戊大大順便偷偷告訴我吧~~~

Answer 3

打岔一下...三位的程式碼有個小問題
若輸入的字串有重複,則會重複印出
例如：AACC,1313這樣..

2006-09-23 00:05:05 補充：
有個疑問,阿戊大大可以使用 編輯 功能 ?

2006-09-23 22:48:11 補充：
我也來湊一腳.Dim cnt%Private Sub Command1_Click()   Cls   Dim txt$, lnS%, asw As Byte, AR As Variant, i%, j%, fstr As String   Me.FontName = "細明體"   txt = InputBox("輸入字串", , "1234")   If StrPtr(txt) = 0 Then Exit Sub   lnS = Len(txt):   cnt = 1   If lnS <= 1 Then Print txt: Exit Sub   fstr = txt & " "   Call myLoop(txt, lnS, lnS, fstr)   AR = Split(fstr)   For i = 0 To UBound(AR) - 1      For j = 1 To lnS         Print Mid(AR(i), j, 1) & IIf(j < lnS, ",", "");      Next      Print   Next   Me.Caption = "共 " & cnt & "種組合"End SubPublic Function RR(ByVal txt As String, ByVal length As Integer) As String   bak = Left(txt, Len(txt) - length)   txt = Right(txt, length)   RR = bak & Right(txt, 1) & Left(txt, Len(txt) - 1)End FunctionPublic Sub myLoop(ByVal xS$, ByVal Y%, ByVal asw%, ByRef fstr)   For i = 1 To Y      If asw <> 2 Then Call myLoop(xS, Y - 1, asw - 1, fstr)      xS = RR(xS, asw)      If i < Y And InStr(fstr, xS) = 0 Then fstr = fstr & xS & " ": cnt = cnt + 1   NextEnd Sub

Answer 4

Dim K#Private Sub Command1_Click()    Dim S$        S = InputBox("輸入字串", , 1234)    If S = "" Then Exit Sub    Me.Cls: K = 0    Dictionary S, Len(S), Len(S)    Caption = "組合完成,共" & K & "種組合"End SubSub Dictionary(ByVal W$, A%, ByVal N%)    Dim I%    If N = 2 Then        For I = A - 1 To A            Print W: K = K + 1            If K Mod 5 = 0 Then Caption = "共" & K & "種組合"            W = Chg(W, A - 1, A)        Next I    Else        For I = A - N + 1 To A            Call Dictionary(Chg(W, A - N + 1, I), A, N - 1)        Next I    End IfEnd SubFunction Chg$(S$, F%, L%)    If F = L Then        Chg = S    Else        Chg = Mid$(S, 1, F - 1) + Mid$(S, L, 1) + Mid$(S, F, 1) + Mid$(S, F + 1, L - F - 1) + Mid$(S, L + 1, Len(S) - L)    End IfEnd Function報告戊大收到^-^喽,感謝再感謝(痛哭流涕中)順便慶祝王建民第18勝到手
圖片參考：http://i106.photobucket.com/albums/m253/WJS_HVM/WJS1/CMW3.gif


2006-09-22 14:57:37 補充：
遞迴才是王道@@

2006-09-22 18:19:02 補充：
在下認為應該要照排,畢竟原意是要做排列組合,而刪除重複的部分則不在限制內XD

2006-09-25 16:17:03 補充：
此題最大的收穫是>>>以後不用再被知識+綁死^_^

Answer 5

排列組合有專門的演算法，效率會比幾種組合寫幾層迴圈還要好喔。

Answer 6

果然BF是王道!....
Orz....

2006-09-22 18:20:19 補充：
next_permutation才是王道!...XD
(人家不是問你C++...XD而且這是犯規的行為!)

Answer 7

排列組合
概念是將數字字組中的位置與最後一個互換，直到字組中最大數量為止

Dim mStr As String
Dim mCount As Long

Function p遞回(p數字陣列() As Long, p最大值 As Long, p目前位置 As Long) As String
Dim m備份字元 As Long
Dim i As Long
Dim j As Long

If p目前位置 = p最大值 Then
' 印出排列方式
mStr = mStr & vbCrLf & mCount & ":"
For i = 1 To p最大值
mStr = mStr & p數字陣列(i)
Next
mCount = mCount + 1
Else
For i = p目前位置 To p最大值
m備份字元 = p數字陣列(i)
' 置換右邊的數字到左邊
For j = i To p目前位置 + 1 Step -1
p數字陣列(j) = p數字陣列(j - 1)
Next

p數字陣列(p目前位置) = m備份字元
Call p遞回(p數字陣列(), p最大值, p目前位置 + 1)

' 還原數字
For j = p目前位置 To i - 1
p數字陣列(j) = p數字陣列(j + 1)
Next
p數字陣列(i) = m備份字元
Next
End If

End Function

Private Sub Form_Activate()
Dim m數字陣列(4) As Long
Dim i As Long

mStr = ""
mCount = 1

For i = 1 To 4
m數字陣列(i) = i
Next
Call p遞回(m數字陣列(), 4, 1)
mStr = mStr & vbCrLf & vbCrLf & "一共:" & mCount - 1 & "個"
MsgBox mStr
Debug.Print mStr

End Sub




當中的變數名稱我儘量使用中文，讓你在閱讀瀏覽上較為方便
希望以上程式對你有所幫助

2006-09-24 00:16:05 補充：
感到下面有一些壓力...................