順列の作成

A B C D E　５枚のカードがあり、これらを１列に５枚全部並べる時の並べ方は５！通りです。この５！通りの文字列をVBAで作成したいのですが、アルゴリズムからして思いつきません。並べ替え規則というか方法を教えて下さい。

No.4 ベストアンサー 回答者： tatsu99 回答日時： 2015/08/24 03:43

アルゴリズムでいえば以下のようになります。

配列数＝５でA,B,C,D,Eの文字で行なう場合
１．配列数の数だけ以下を繰り返す（５回繰り返し）
　　配列から繰り返し番目に該当する１文字を取得する。（文字１とする）（１回目はA、２回目はB・・・となる）
　　その文字を除いたもので、新しい配列を作る。1回目は(B,C,D,E)、２回目は(A,C,D,E)・・・となる。
　　２．新しい配列の配列の数だけ以下を繰り返す（４回繰り返し）
　　　　繰り返し番目に該当する１文字を取得する。（文字２とする）
　　　　その文字を除いたもので、新しい配列を作る。１回目は（C,D,E）・・・となる。
　　　　３．新しい配列の配列の数だけ以下を繰り返す（３回繰り返し）
　　　　　　以下同様（文字３）
　　　　　　４．新しい配列の配列の数だけ以下を繰り返す（２回繰り返し）
　　　　　　　　以下同様（文字４）
　　　　　　　　５．新しい配列の配列の数だけ以下を繰り返す（１回繰り返し）
　　　　　　　　　　以下同様（文字５）
　　　　　　　　　　６．配列の数が０個なので以下の処理を行う
　　　　　　　　　　　　組合せの文字列＝文字１＋文字２＋文字３＋文字４＋文字５
　　　　　　　　　　　　組合せの文字列をファイルへ出力する
　　　　　　　　５．繰り返し終了
　　　　　　４．繰り返し終了
　　　　３．繰り返し終了
　　２．繰り返し終了
１．繰り返し終了

実装例は以下の通り（但し、配列数は１０個で行っています）（sub1は再帰呼び出しを行っています）
---------------------------------------------
Option Explicit
Sub test()
Dim i As Integer
Dim arr As New Collection
Const cnsFILENAME = "\SAMPLE.txt"
Open ThisWorkbook.Path & cnsFILENAME For Output As #100

For i = 0 To 9
arr.Add (Chr(Asc("A") + i))
Next
MsgBox ("start")
Call sub1(arr, "")
Close #100
MsgBox ("end")
End Sub
Sub sub1(ByRef arr As Collection, ByVal out As String)
Dim str As Variant
Dim s As Variant
If arr.Count < 1 Then
Print #100, out
Exit Sub
End If
Dim i As Integer
For Each str In arr
Dim ar As Collection
Set ar = New Collection
For Each s In arr
If s <> str Then
ar.Add (s)
End If
Next
Call sub1(ar, out + str)
Next
End Sub

----------------------------------------------------------------------------
excelのbookが存在するディレクトリと同じディレクトリ下にSAMPLE.txtが作成されます。
先頭行：ABCDEFGHIJ（1行目）
最終行：JIHGFEDCBA（3628800行目）
になります。
excelのシートへ出力すると行数が多いため、出力できませんのでファイルへ出力しています。

この回答へのお礼

ありがとうございます。
確認できました。これで行きます。

お礼日時：2015/08/29 02:32

No.3 回答者： 30246kiku 回答日時： 2015/08/23 20:42

ベタですが、以下でどうでしょう

アクティブシートの A1 ～ A5 に文字入れて実行すると
新規シートに出力します

※ Application.ScreenUpdating 等は必要に応じて追加してください


Option Explicit

Dim vA As Variant, vB As Variant
Dim iRow As Long

Public Sub Samp1()
　　vA = WorksheetFunction.Transpose( _
　　　　　　Range("A1", Cells(Rows.Count, "A").End(xlUp)))
　　ReDim vB(1 To UBound(vA))

　　Worksheets.Add
　　iRow = 1
　　Call ReCode(1)
End Sub

Private Sub ReCode(iP As Long)
　　Dim i As Long

　　For i = 1 To UBound(vA)
　　　　If (IsEmpty(vB(i))) Then
　　　　　　vB(i) = vA(iP)
　　　　　　If (iP = UBound(vA)) Then
　　　　　　　　Cells(iRow, "A").Resize(, UBound(vB)) = vB
　　　　　　　　iRow = iRow + 1
　　　　　　　　vB(i) = Empty
　　　　　　　　Exit Sub
　　　　　　Else
　　　　　　　　Call ReCode(iP + 1)
　　　　　　　　vB(i) = Empty
　　　　　　End If
　　　　End If
　　Next
End Sub


何が速いのかわかりませんけど

後は、求めたい個数を分割して･･･
例えば、１０個の文字なら、2-4-4 とか、1-3-3-3 とかのブロックにして
各ブロック内の順の直積にしてみるとか･･･

例になるかどうかですが、
１０文字のもので、何文字目･･･に番号を付けたとして
（１０個から２個の組み合わせを求め、
残った８個から４個の組み合わせを求めて、最後のは残った４個）

1,2 - 3,4,5,6 - 7,8,9,10

が求まっていたとすると

7,8,9,10 の順は

7,8,9,10
7,8,10,9
7,9,8,10
7,9,10,8
7,10,8,9
7,10,9,8
8,7,9,10
････の２４通り

1,2 - 3,4,5,6 - xxxx の xxxx は上記の 24 通りになり
1,2 - 3,4,6,5 - yyyy の yyyy は、xxxx=yyyy なので使いまわし可？･･･

何が速い･･･は、要求仕様がどうなのか･･･と思います。

速さを追求する予定のない者からでした
（嘘があったらごめんなさい）


なお、上記では再帰してましたが、Loop 等に変更すると
それなりに速くなると思います。

この回答へのお礼

ありがとうございます。
グループ分けはちょっと難しそうです。

お礼日時：2015/08/29 02:33

No.2 回答者： nag0720 回答日時： 2015/08/23 14:02

Sub test()

Dim Size As Integer, n As Integer, i As Integer, i1 As Integer, i2 As Integer

Size = 5
n = 1
For i = 1 To Size
Cells(n, i) = Chr(Asc("A") + i - 1)
Next

Do
i1 = 0
For i = Size To 2 Step -1
If Cells(n, i - 1) < Cells(n, i) Then
i1 = i - 1
Exit For
End If
Next
If i1 <= 0 Then Exit Do
i2 = Size
For i = i1 + 1 To Size
If Cells(n, i1) >= Cells(n, i) Then
i2 = i - 1
Exit For
End If
Next

n = n + 1
For i = 1 To i1 - 1
Cells(n, i) = Cells(n - 1, i)
Next
For i = i1 + 1 To Size
Cells(n, i) = Cells(n - 1, Size + i1 + 1 - i)
Next
Cells(n, i1) = Cells(n - 1, i2)
Cells(n, Size + i1 + 1 - i2) = Cells(n - 1, i1)
Loop

End Sub

No.1 回答者： soixante 回答日時： 2015/08/23 12:45

強引ですが以下のようにやってみました。

まず、5^5通りのパターンをすべて書き出し、重複している文字がある行を削除してみました。

----------------------------------------------------------
Option Explicit

Sub ZZZZ()
Dim a As Integer, b As Integer, c As Integer, d As Integer, e As Integer
Dim r As Integer, Rng As Range, Hantei As Integer
Dim WSF As Object
Set WSF = Application.WorksheetFunction

'全パターンを羅列
r = 2
For a = 65 To 69
For b = 65 To 69
For c = 65 To 69
For d = 65 To 69
For e = 65 To 69
Cells(r, 1).Value = Chr(a)
Cells(r, 2).Value = Chr(b)
Cells(r, 3).Value = Chr(c)
Cells(r, 4).Value = Chr(d)
Cells(r, 5).Value = Chr(e)
r = r + 1
Next e
Next d
Next c
Next b
Next a

'各文字の個数をカウント
r = 2
Do While Cells(r, 1).Value <> ""
Set Rng = Range(Cells(r, 1), Cells(r, 5))
For c = 6 To 10
Cells(r, c).Value = WSF.CountIf(Rng, Chr(c + 59))
Next c
r = r + 1
Loop

'すべて１以外の行は削除
Application.ScreenUpdating = False
a = Cells(Rows.Count, 1).End(xlUp).Row
For r = a To 2 Step -1
For c = 6 To 10
If Cells(r, c).Value = 0 Then
Rows(r).Delete
Exit For
End If
Next c
Next r
Range(Columns(6), Columns(10)).Delete
Application.ScreenUpdating = True

Set WSF = Nothing
Set Rng = Nothing
MsgBox "End."
End Sub
-----------------------------------------------------------------------------

もっとスマートな方法の回答が付くと思いますので、ご参考程度でお願いしますm(_ _)m

この回答へのお礼

ありがとうございます。
実際にはカード10枚なので、回答頂いた方法では時間がかかり過ぎます。後出しジャンケンですみません。

また、マクロ自体は必須ではありません。あれば助かりますが、望みはアルゴリズムです。

お礼日時：2015/08/23 13:28