エクセルＶＢＡ 全ての組み合わせを作る

エクセルＶＢＡで、全ての組み合わせを表現する方法を教えてください

既にＡ列に色、Ｂ列に数字、Ｃ列にサイズが入力済みだとします
　　Ａ　　Ｂ　　Ｃ
1　 色 　数字　サイズ　←タイトルの行
2　 赤 　 １　　Ｓ
3　 青 　 ２　　Ｍ
4　 緑 　 ３　　Ｌ

（完成例）
　　Ｄ　　Ｅ　　Ｆ
1　 色 　数字　サイズ　←タイトルの行
2　 赤 　 １　　Ｓ
3　 赤 　 １　　Ｍ
4　 赤 　 １　　Ｌ
5　 赤　　２　　Ｓ
6　 赤　　２　　Ｍ
7　 赤　　２　　Ｌ
8　 赤　　３　　Ｓ
9　 赤　　３　　Ｍ
10　赤　　３　　Ｌ
11　青 　 １　　Ｓ
12　青 　 １　　Ｍ
13　青 　 １　　Ｌ
14　青　　２　　Ｓ
15　青　　２　　Ｍ
16　青　　２　　Ｌ
17　青　　３　　Ｓ
18　青　　３　　Ｍ
19　青　　３　　Ｌ
20　緑 　 １　　Ｓ
21　緑 　 １　　Ｍ
22　緑 　 １　　Ｌ
23　緑　　２　　Ｓ
24　緑　　２　　Ｍ
25　緑　　２　　Ｌ
26　緑　　３　　Ｓ
27　緑　　３　　Ｍ
28　緑　　３　　Ｌ

・全ての組み合わせが表現できていれば、2～28行目は上の完成例の順番でなくてもいいです
・完成はＤ～Ｆ列の上から（2行目から）結果を反映させ、空白行を作らないようにする
・今回はＡ～Ｃ列の4行まで入力されている例をあげましたが、実際はＡ～Ｃ列の何行まで入力されているか随時変更します
・Ａ～Ｃ列のデータ入力は、必ず上から（2行目から）されています
・Ａ～Ｃ列のデータ入力は、5行目以降に続くこともあります
・Ａ～Ｃ列のデータ入力は、データがない場合もあります

（データ入力がない場合）
　　Ａ　　Ｂ　　Ｃ
1　 色 　数字　サイズ　←タイトルの行
2　 　 　 １　　Ｓ
3　 　 　 ２　　Ｍ
4　 　 　 　　　Ｌ

（この場合の完成例）
　　Ｄ　　Ｅ　　Ｆ
1　 色 　数字　サイズ　←タイトルの行
2　 　 　 １　　Ｓ
3　 　 　 １　　Ｍ
4　 　 　 １　　Ｌ
5　 　　　２　　Ｓ
6　 　　　２　　Ｍ
7　 　　　２　　Ｌ


空白行が出来てしまってはいけないので、『まずデータ入力されている列を認識し、認識した列の情報で全ての組み合わせを作成する』という考え方なのかな？と思ったのですが、そのようなことをエクセルＶＢＡでできるのでしょうか
もし分かる方がいたら教えてください
よろしくお願いします

No.7 回答者： CoalTar 回答日時： 2014/01/06 18:32

関数だと速いのかなあ なんて思いから ちょっとやってみました

Sub 並べるXL2003()
Dim n As Long
Dim n2 As Long
Dim n3 As Long
Dim n4 As Long

　 　Range("D1").Formula = "=IF(A2="""","""",COUNTA(A:A)-1)"
　 　Range("E1").Formula = "=IF(B2="""","""",COUNTA(B:B)-1)"
　 　Range("F1").Formula = "=IF(C2="""","""",COUNTA(C:C)-1)"
　 　Range("G1").Formula = "=PRODUCT(E1,F1)"
　 　Range("H1").Formula = "=PRODUCT(D1:F1)"
　 　If Range("H1") > 65535 * 4 Then Exit Sub
　 　n = WorksheetFunction.Min(Range("H1") + 1, 65536)
　 　Range("D2:D" & n).Formula = "=INDEX(A:A,2+(ROW()-2)/G$1)"
　 　Range("D2:D" & n).Value = Range("D2:D" & n).Value
　 　Range("E2:E" & n).Formula = "=INDEX(B:B,2+MOD((ROW()-2)/F$1,E$1))"
　 　Range("E2:E" & n).Value = Range("E2:E" & n).Value
　 　Range("F2:F" & n).Formula = "=INDEX(C:C,2+MOD(ROW()-2,F$1))"
　 　Range("F2:F" & n).Value = Range("F2:F" & n).Value
If Range("H1") <= 65535 Then Exit Sub
n2 = WorksheetFunction.Min(Range("H1") - 65535 + 1, 65536)
　 　Range("G2:G" & n2).Formula = "=INDEX(A:A,2+(ROW()-2+65535)/G$1)"
　 　Range("G2:G" & n2).Value = Range("G2:G" & n2).Value
　 　Range("H2:H" & n2).Formula = "=INDEX(B:B,2+MOD((ROW()-2+65535)/F$1,E$1))"
　 　Range("H2:H" & n2).Value = Range("H2:H" & n2).Value
　 　Range("I2:I" & n2).Formula = "=INDEX(C:C,2+MOD(ROW()-2+65535,F$1))"
　 　Range("I2:I" & n2).Value = Range("I2:I" & n2).Value
If Range("H1") <= 65535 * 2 Then Exit Sub
n3 = WorksheetFunction.Min(Range("H1") - 65535 * 2 + 1, 65536)
　 　Range("J2:J" & n3).Formula = "=INDEX(A:A,2+(ROW()-2+65535*2)/G$1)"
　 　Range("J2:J" & n3).Value = Range("J2:J" & n2).Value
　 　Range("K2:K" & n3).Formula = "=INDEX(B:B,2+MOD((ROW()-2+65535*2)/F$1,E$1))"
　 　Range("K2:K" & n3).Value = Range("K2:K" & n2).Value
　 　Range("L2:L" & n3).Formula = "=INDEX(C:C,2+MOD(ROW()-2+65535*2,F$1))"
　 　Range("L2:L" & n3).Value = Range("L2:L" & n2).Value
n4 = WorksheetFunction.Min(Range("H1") - 65535 * 3 + 1, 65536)
　 　Range("M2:M" & n4).Formula = "=INDEX(A:A,2+(ROW()-2+65535*3)/G$1)"
　 　Range("M2:M" & n4).Value = Range("M2:M" & n2).Value
　 　Range("N2:N" & n4).Formula = "=INDEX(B:B,2+MOD((ROW()-2+65535*3)/F$1,E$1))"
　 　Range("N2:N" & n4).Value = Range("N2:N" & n2).Value
　 　Range("O2:O" & n4).Formula = "=INDEX(C:C,2+MOD(ROW()-2+65535*3,F$1))"
　 　Range("O2:O" & n4).Value = Range("O2:O" & n2).Value

End Sub
約25万件になるデータが11秒ほどでできました
遊びですがf(^^;

No.6 回答者： tom04 回答日時： 2014/01/06 15:59

No.5です。

たびたびごめんなさい。

前回の
＞No.1さんの補足に
は
＞No.2さんの
の間違いです。ごめんなさい。

それと、前回のコードはA～C列の1行目からデータがある！という前提のコードでしたが
1行目は項目行になっていてデータは2行目からあるのですよね？

For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
For j = 1 To Cells(Rows.Count, "B").End(xlUp).Row
For k = 1 To Cells(Rows.Count, "C").End(xlUp).Row

の3行の「1」をすべて「2」に変更してください。

どうも失礼しました。m（_ _）m

No.5 回答者： tom04 回答日時： 2014/01/06 14:04

こんにちは！

横からお邪魔します。

No.1さんの補足に
＞今のところ、最大で238,238の組み合わせが生じそうです
とありますので・・・

Sub Sample1()
Dim i As Long, j As Long, k As Long, cnt As Long, myRow As Long, myCol As Long, endCol As Long
endCol = ActiveSheet.UsedRange.Columns.Count
If endCol > 3 Then
Range(Columns(4), Columns(endCol)).ClearContents
End If
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
For j = 1 To Cells(Rows.Count, "B").End(xlUp).Row
For k = 1 To Cells(Rows.Count, "C").End(xlUp).Row
cnt = cnt + 1
If cnt Mod 65536 = 0 Then
myRow = 65536
myCol = Int(cnt / 65536) * 3 + 1
Else
myRow = cnt Mod 65536
myCol = (Int(cnt / 65536) + 1) * 3 + 1
End If
With Cells(myRow, myCol)
.Value = Cells(i, "A")
.Offset(, 1) = Cells(j, "B")
.Offset(, 2) = Cells(k, "C")
End With
Next k
Next j
Next i
MsgBox "処理完了"
End Sub

※　じっくり考えれば1セルずつ舐めるように表示させるより、一定範囲をコピー＆ペーストすれば
もっと早くなると思いますが、65536行目がどこで終わるか？の判断が難しくなりますので、
単純にずらぁ～～～！っと並べています。

腕組みをしてじっくり画面とにらめっこしてください。m（_ _）m

この回答へのお礼

回答ありがとうございます


返信が遅くなりすみませんでした

お礼日時：2014/01/13 21:02

No.4 回答者： keithin 回答日時： 2014/01/05 23:11

んじゃまぁついでに。

sub macro1for2003()
　dim c1 as long, c2 as long, c3 as long
　dim r as long
　dim w as worksheet
　set w = activesheet
　range("D:F").clearcontents
　range("A1:C1").copy range("D1")
　r = 2

　for c1 = 2 to application.max(2, w.cells(rows.count, "A").end(xlup).row)
　　for c2 = 2 to application.max(2, w.cells(rows.count, "B").end(xlup).row)
　　　for c3 = 2 to application.max(2, w.cells(rows.count, "C").end(xlup).row)

　　　if r > 65536 then
　　　　worksheets.add after:=activesheet
　　　　w.range("A1:C1").copy range("D1")
　　　　r = 2
　　　end if

　　　　cells(r, "D").value = w.cells(c1, "A").value
　　　　cells(r, "E").value = w.cells(c2, "B").value
　　　　cells(r, "F").value = w.cells(c3, "C").value
　　　　r = r + 1

　　　next c3
　　next c2
　next c1
end sub


言わずもがなですが、わざわざ65536までひっぱる必要は勿論ありません。
もっとも１０万行を超える書き出しを逐一行ってると、随分とろくさいですけどね。

この回答へのお礼

2003用までありがとうございます

このようなコードを作成したおことがないのですが、最終行までいくと、新しいシートが作成させるのでしょうか？
できれば一つのシートで完成させたいので、(1)エクセル2003では使用しない、(2)入力できるデータ数を制限する、で何とか１つのシートで完成しようと思います
本当に助かりました

お礼日時：2014/01/05 23:54

No.3 回答者： keithin 回答日時： 2014/01/05 22:44

＞●＝２は何を意味するのでしょうか？

ＡＢＣ列に記入が無い場合の対処です。




＞■で65536を使わずにできないかな？と思い

現実問題としてＡＢＣ列に６万を超える「リストの元ネタ」を、本当に並べるつもりがあるのですか？（ＤＥＦ列の事じゃ勿論ありませんよ）
もしマジメにそうする必要があってそうしたいと言うのでしたら、勿論そのように対処してください。
ふつーに考えると「A9999」とかでも全然十分だと思ってましたけどね。

sub macro1r1()
　dim c1 as long, c2 as long, c3 as long
　dim r as long
　range("D:F").clearcontents
　range("A1:C1").copy range("D1")
　r = 2

　for c1 = 2 to application.max(2, cells(rows.count, "A").end(xlup).row)
　　for c2 = 2 to application.max(2, cells(rows.count, "B").end(xlup).row)
　　　for c3 = 2 to application.max(2, cells(rows.count, "C").end(xlup).row)

　　　　cells(r, "D").value = cells(c1, "A").value
　　　　cells(r, "E").value = cells(c2, "B").value
　　　　cells(r, "F").value = cells(c3, "C").value
　　　　r = r + 1

　　　next c3
　　next c2
　next c1
end sub

この回答へのお礼

分かりやすい説明ありがとうございます
後になり、Cells(Rows.Count, 1).End(xlUp).Row
で解決すると気が付きました

ありがとうございます

お礼日時：2014/01/05 23:46

No.2 回答者： MarcoRossiItaly 回答日時： 2014/01/05 14:47

基本的には No.1 さんの方法でいいと思いますが、シートの最大の行数に注意してください。

Excel 2003 以前で 65,536、Excel 2007 以後で 1,048,576 です。

組み合わせの数は、爆発的に増加します。質問文の例だと色・数字・サイズという 3 属性が 3 種類ずつなので、組み合わせの数は 3^3 = 27 通りとなりますね。

しかし 41 種類ずつだと 41^3 = 68,921、102 種類ずつだと 102^3 = 1,061,208 となって、すぐに制限を超えてしまいます。他にも例えば、色・数字・サイズが 20・350・10 であれば 20 x 350 x 10 = 70,000、120・1,000・10 であれば 120 x 1,000 x 10 = 1,200,000 などとなり、やはりオーバーします。

ですから制限を超えそうな場合は、途中で列を変えて続きを記入していくなどの工夫が必要になります。コード中、For の行に記述している行番号の変数（No.1 さんのコードで言えば c1 あたり）の最大値を調節することなどによって、途中で無事に終われます。

そうしておかないと、最大の行数までの記入は実行されますが、その次の記入でマクロがエラーになります。

なおマクロの実行にかかる時間は、環境にもよりますが、100 万行を記入するなら何分かかかると思ってください。


＞……、『まずデータ入力されている列を認識し、……と思ったのですが、そのようなことをエクセルＶＢＡでできるのでしょうか

条件に関する必要な情報が十分に与えられれば、その手のことはいくらでも可能だと思います。しかし難しいことをしようとするほど、VBA に関する様々な知識が必要になっていきます。まずは基本の処理を習得し、それ以上のことは追々、学んでいってください。

この回答へのお礼

回答ありがとうございます

今のところ、最大で238,238の組み合わせが生じそうです
既にエクセル2003では超えてしまいますね
また、データが今後増えていくことが予想できるので

エクセル2003で使用できるように、入力できるデータ数を制限するのも一つの手かなと考えています
ありがとうございました

お礼日時：2014/01/05 21:24

No.1 回答者： keithin 回答日時： 2014/01/05 02:08

奇をてらわずに、単純にぐるぐる廻してくだけで十分です。

sub macro1()
　dim c1 as long, c2 as long, c3 as long
　dim r as long
　range("D:F").clearcontents
　range("A1:C1").copy range("D1")
　r = 2

　for c1 = 2 to application.max(2, range("A65536").end(xlup).row)
　　for c2 = 2 to application.max(2, range("B65536").end(xlup).row)
　　　for c3 = 2 to application.max(2, range("C65536").end(xlup).row)

　　　　cells(r, "D").value = cells(c1, "A").value
　　　　cells(r, "E").value = cells(c2, "B").value
　　　　cells(r, "F").value = cells(c3, "C").value
　　　　r = r + 1

　　　next c3
　　next c2
　next c1
end sub

この回答へのお礼

早い回答ありがとうございます

意外と短く表現できるんですね！
助かりました

Application.Max(●, ■)で、最大行を取得しているんだと思うのですが、
●＝２は何を意味するのでしょうか？

また、■で65536を使わずにできないかな？と思い
Cells(Rows.Count, 1).End(xlUp)　としましたが、うまくいきませんね・・

お礼日時：2014/01/05 21:17