No.4ベストアンサー
- 回答日時:
アルゴリズムでいえば以下のようになります。
配列数=5でA,B,C,D,Eの文字で行なう場合
1.配列数の数だけ以下を繰り返す(5回繰り返し)
配列から繰り返し番目に該当する1文字を取得する。(文字1とする)(1回目はA、2回目はB・・・となる)
その文字を除いたもので、新しい配列を作る。1回目は(B,C,D,E)、2回目は(A,C,D,E)・・・となる。
2.新しい配列の配列の数だけ以下を繰り返す(4回繰り返し)
繰り返し番目に該当する1文字を取得する。(文字2とする)
その文字を除いたもので、新しい配列を作る。1回目は(C,D,E)・・・となる。
3.新しい配列の配列の数だけ以下を繰り返す(3回繰り返し)
以下同様(文字3)
4.新しい配列の配列の数だけ以下を繰り返す(2回繰り返し)
以下同様(文字4)
5.新しい配列の配列の数だけ以下を繰り返す(1回繰り返し)
以下同様(文字5)
6.配列の数が0個なので以下の処理を行う
組合せの文字列=文字1+文字2+文字3+文字4+文字5
組合せの文字列をファイルへ出力する
5.繰り返し終了
4.繰り返し終了
3.繰り返し終了
2.繰り返し終了
1.繰り返し終了
実装例は以下の通り(但し、配列数は10個で行っています)(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のシートへ出力すると行数が多いため、出力できませんのでファイルへ出力しています。
No.3
- 回答日時:
ベタですが、以下でどうでしょう
アクティブシートの 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
何が速いのかわかりませんけど
後は、求めたい個数を分割して・・・
例えば、10個の文字なら、2-4-4 とか、1-3-3-3 とかのブロックにして
各ブロック内の順の直積にしてみるとか・・・
例になるかどうかですが、
10文字のもので、何文字目・・・に番号を付けたとして
(10個から2個の組み合わせを求め、
残った8個から4個の組み合わせを求めて、最後のは残った4個)
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
・・・・の24通り
1,2 - 3,4,5,6 - xxxx の xxxx は上記の 24 通りになり
1,2 - 3,4,6,5 - yyyy の yyyy は、xxxx=yyyy なので使いまわし可?・・・
何が速い・・・は、要求仕様がどうなのか・・・と思います。
速さを追求する予定のない者からでした
(嘘があったらごめんなさい)
なお、上記では再帰してましたが、Loop 等に変更すると
それなりに速くなると思います。
No.2
- 回答日時:
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
- 回答日時:
強引ですが以下のようにやってみました。
まず、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
'すべて1以外の行は削除
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
この回答へのお礼
お礼日時:2015/08/23 13:28
ありがとうございます。
実際にはカード10枚なので、回答頂いた方法では時間がかかり過ぎます。後出しジャンケンですみません。
また、マクロ自体は必須ではありません。あれば助かりますが、望みはアルゴリズムです。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Excel(エクセル) 結合セルのソートについて 5 2022/04/22 11:57
- 数学 「1~5の数字が書かれたカードが5枚ある。(すべてのカードには異なった数字が書かれている) この5枚 4 2023/02/16 11:22
- 数学 1から9の数字を書いたカードが一枚ずつある。これらの9枚のカードから同時に2枚を取り出し、数字の大き 5 2022/04/25 15:38
- 計算機科学 アルゴリズムについて 1 2023/01/01 19:43
- 数学 確率の問題です。 1、1、2、2、2、3の6枚のカードを1列に並べて6桁の整数を作る時なん通りですか 2 2023/01/18 15:18
- 数学 数学(順列)(訳あり再質問) 男子3人と女子5人が1列に並ぶとき両端うち少なくとも一方は男子である並 1 2023/02/16 10:26
- 数学 数学(順列) 男子3人と女子5人が1列に並ぶとき両端うち少なくとも一方は男子である並び方は 何通りあ 1 2023/02/15 21:09
- Excel(エクセル) DATEDIFで作成した勤務年数の並べ替えがうまくいかない 3 2023/07/31 17:09
- その他(Microsoft Office) 1の行を固定した上でVBAを用いて日付順に自動並べ替え 2 2022/06/06 15:09
- 数学 【 数A 順列 】 問題 A,B,C,D,E,F,Gの7人が1列に並ぶとき, A,Bの2人が間に2人 4 2022/06/19 12:48
このQ&Aを見た人はこんなQ&Aも見ています
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
配列数式の解除
-
2つ以上の変数を比較して最大数...
-
配列で飛び飛びの値を指定して...
-
特定のセル範囲で4文字以上入力...
-
fortranのプログラムで困ってい...
-
行列の積の計算プログラムを教...
-
VB2008: CSV を二次元配列に読...
-
VB.NET2015 サブルーチンの使い方
-
for each の現在の配列ポインタ...
-
クイックソート
-
fortran 渡す値について
-
コンボボックスの記述の簡素化
-
マクロの記録を使用したマクロ...
-
Excel マクロ VBA プロシー...
-
メッセージボックスのOKボタ...
-
教えて下さい
-
ExcelVBAでPDFを閉じるソース
-
ExcelのVBAを使ってタイトル行...
-
特定のPCだけ動作しないVBAマク...
-
UserForm1.Showでエラーになり...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
配列数式の解除
-
2つ以上の変数を比較して最大数...
-
for each の現在の配列ポインタ...
-
配列変数の添字が範囲外ですと...
-
VBA 1次元配列を2次元に追加する
-
特定のセル範囲で4文字以上入力...
-
subの配列引数をoptionalで使う...
-
ListViewで、非表示列って作れ...
-
VB6 配列を初期化したい
-
Excel-VBAの配列「Public Const...
-
配列を任意の数値で埋める方法
-
VBのFunctionで、配列を引数...
-
Dim は何の略ですか?
-
2次元動的配列の第一引数のみを...
-
verilogで配列の任意の8bitを取...
-
エクセルで最小値から0を除く方法
-
VBA Match関数の限界
-
Excel VBA配列をFunctionに渡す
-
VB2008: CSV を二次元配列に読...
-
fortranでのcsvファイルの読み込み
おすすめ情報