プロが教えるわが家の防犯対策術!

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

既にA列に色、B列に数字、C列にサイズが入力済みだとします
  A  B  C
1  色  数字 サイズ ←タイトルの行
2  赤   1  S
3  青   2  M
4  緑   3  L

(完成例)
  D  E  F
1  色  数字 サイズ ←タイトルの行
2  赤   1  S
3  赤   1  M
4  赤   1  L
5  赤  2  S
6  赤  2  M
7  赤  2  L
8  赤  3  S
9  赤  3  M
10 赤  3  L
11 青   1  S
12 青   1  M
13 青   1  L
14 青  2  S
15 青  2  M
16 青  2  L
17 青  3  S
18 青  3  M
19 青  3  L
20 緑   1  S
21 緑   1  M
22 緑   1  L
23 緑  2  S
24 緑  2  M
25 緑  2  L
26 緑  3  S
27 緑  3  M
28 緑  3  L

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

(データ入力がない場合)
  A  B  C
1  色  数字 サイズ ←タイトルの行
2      1  S
3      2  M
4         L

(この場合の完成例)
  D  E  F
1  色  数字 サイズ ←タイトルの行
2      1  S
3      1  M
4      1  L
5     2  S
6     2  M
7     2  L


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

A 回答 (7件)

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


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(^^;
    • good
    • 0

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
    • good
    • 1

こんにちは!


横からお邪魔します。

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
    • good
    • 0
この回答へのお礼

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


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

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

んじゃまぁついでに。



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までひっぱる必要は勿論ありません。
もっとも10万行を超える書き出しを逐一行ってると、随分とろくさいですけどね。
    • good
    • 1
この回答へのお礼

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

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

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

>●=2は何を意味するのでしょうか?



ABC列に記入が無い場合の対処です。




>■で65536を使わずにできないかな?と思い

現実問題としてABC列に6万を超える「リストの元ネタ」を、本当に並べるつもりがあるのですか?(DEF列の事じゃ勿論ありませんよ)
もしマジメにそうする必要があってそうしたいと言うのでしたら、勿論そのように対処してください。
ふつーに考えると「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
    • good
    • 0
この回答へのお礼

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

ありがとうございます

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

基本的には 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でできるのでしょうか

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

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

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

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

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

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



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
    • good
    • 0
この回答へのお礼

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

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

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

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

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

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています


このQ&Aを見た人がよく見るQ&A

このカテゴリの人気Q&Aランキング