Excelでデータ全通り組み合わせ出力方法

Excelでデータ全通り組み合わせ出力方法について教えて頂けますと助かります。

セルA～Eに、数がまちまちのアイテム名が入っています。
（セルA～Eというのは例で、変則的に全てのアイテム数は増減します。）

全ての組合せをセルG～Kに各々書き出してくれる方法はあるでしょうか？
（イメージ添付あり）

できればセルに入力すれば自動的に組合せが追加されていくのが理想です。
Excel2010を使用しており、VBAは初心者です。


どなたかご存じでしたら、ぜひお教え下さい。
よろしくお願いします。

No.4 ベストアンサー 回答者： cj_mover 回答日時： 2013/10/22 17:29

＃１、２、ｃｊです。

＃１、２、補足欄へのレスです。

取り急ぎ、コードのみ修正しました。
＃２を元に書き換えています。

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim rSrc As Range
　　Application.EnableEvents = False
　　Set rSrc = Range("B2").CurrentRegion
　　Application.EnableEvents = True
　　If Intersect(Target, rSrc) Is Nothing Then Exit Sub
　　Application.EnableEvents = False
　　Call PrintCombi(rSrc)
　　Application.EnableEvents = True
End Sub

Sub PrintCombi(ByVal rSrc As Range)
　　Dim tnFld As Long
　　Dim nRc As Long
　　Dim nConti As Long
　　Dim nRow As Long
　　Dim i As Long
　　Dim j As Long

　　tnFld = rSrc.Columns.Count
　　nConti = 1
　　With rSrc(1, rSrc.Columns.Count + 3)
　　　　.CurrentRegion.Clear
　　　　Cells(1).Resize(, tnFld).Copy .Cells(1)
　　　　For i = tnFld To 1 Step -1
　　　　　　nRc = Cells(Rows.Count, i).End(xlUp).Row
　　　　　　nRow = 2
　　　　　　For j = 2 To nRc
　　　　　　　　Cells(j, i).Copy Destination:=.Cells(nRow, i).Resize(nConti)
　　　　　　　　nRow = nRow + nConti
　　　　　　Next j
　　　　　　nConti = nConti * (nRc - 1)
　　　　Next i
　　　　With .Cells(2, 1).Resize(nConti)
　　　　　　For i = 2 To tnFld
　　　　　　　　Range(.Cells(1, i), .Cells(.Cells.Count + 1, i).End(xlUp)).Copy Destination:=.Columns(i)
　　　　　　Next i
　　　　End With
　　End With
End Sub

この回答へのお礼

cj_mover さん

ほんとうに理想が叶いました！
ご丁寧に回答くださり、とても助かりました。
ありがとうございます!!

お礼日時：2013/10/22 18:17

No.3 回答者： kagakusuki 回答日時： 2013/10/22 17:16

　横１列に並んだ6個(A～E列の列数+1)の適当な未使用のセルを作業用セルとして使用します。

　ここでは仮に、M1～R1を作業用セルとして使用するものとします。

　まず、R1セルに

1

と入力して下さい。
　次に、Q1セルに次の関数を入力して下さい。

=MAX(IF(COUNTIF(E:E,"*?"),MATCH("*?",E:E,-1),1),IF(COUNT(E:E),MATCH(MAX(E:E)+1,E:E),1))

　次に、Q1セルをコピーして、M1～P1の範囲に貼り付けて下さい。
　次に、K1セルに次の関数を入力して下さい。

=IF(ROWS($1:1)>PRODUCT($M$1:$Q$1),"",IF(INDEX(E:E,MOD(INT((ROWS($1:1)-1)/PRODUCT(R$1:$R$1)),Q$1)-ROW(E$1)+2)="","",INDEX(E:E,MOD(INT((ROWS($1:1)-1)/PRODUCT(R$1:$R$1)),Q$1)-ROW(E$1)+2)))

　次に、K1セルをコピーして、G1～J1の範囲に貼り付けて下さい。
　次に、K1～J1の範囲をコピーして、同じ列の2行目以下に貼り付けて下さい。

　以上です。

この回答へのお礼

kagakusuki さん

まだうまく使いこなせていないのですが、
ご回答ありがとうございました。

お礼日時：2013/10/22 17:47

No.2 回答者： cj_mover 回答日時： 2013/10/22 16:46

＃１、ｃｊです。

ちょっとミスしましたので、コードの差し替えをお願いします。

加えて、
> 右側、１列挟んで右側に、全通りの組合わせを
> 作成します。
この部分の説明ですが、
右側、２列挟んで右側に、全通りの組合わせを
作成します。
というようにしないと、列を追加しながらの作成がうまく行きませんでした。
実際に試す際も、予め、入力範囲の右側に２列の空列がある状態から
始めるようにしてください。
失礼しました。



' ' ここから



Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim rSrc As Range
　　Application.EnableEvents = False
　　Set rSrc = Range("B2").CurrentRegion
　　Application.EnableEvents = True
　　If Intersect(Target, rSrc) Is Nothing Then Exit Sub
　　Application.EnableEvents = False
　　Call PrintCombi(rSrc)
　　Application.EnableEvents = True
End Sub

Sub PrintCombi(ByVal rSrc As Range)
　　Dim tnFld As Long
　　Dim nRc As Long
　　Dim nConti As Long
　　Dim nRow As Long
　　Dim i As Long
　　Dim j As Long

　　tnFld = rSrc.Columns.Count
　　nConti = 1
　　With rSrc(1, rSrc.Columns.Count + 3)
　　　　.CurrentRegion.Clear
　　　　For i = tnFld To 1 Step -1
　　　　　　nRc = Cells(Rows.Count, i).End(xlUp).Row
　　　　　　nRow = 1
　　　　　　For j = 1 To nRc
　　　　　　　　Cells(j, i).Copy Destination:=.Cells(nRow, i).Resize(nConti)
　　　　　　　　nRow = nRow + nConti
　　　　　　Next j
　　　　　　nConti = nConti * nRc
　　　　Next i
　　　　With .Resize(nConti)
　　　　　　For i = 2 To tnFld
　　　　　　　　Range(.Cells(1, i), .Cells(Rows.Count, i).End(xlUp)).Copy Destination:=.Columns(i)
　　　　　　Next i
　　　　End With
　　End With
End Sub


' ' ここまで

この回答への補足

cj_mover さん！
変更したい箇所があるので、補足入力しました。
どうか気づいてください・・・＞＜

コードの差し替えのご連絡ありがとうございます。

補足日時：2013/10/22 17:01

No.1 回答者： cj_mover 回答日時： 2013/10/22 15:49

こんにちは。

ＶＢＡですが、なるべく基本的な書き方にしました。

適用したいシートを表示して、
シートタブを右クリック、[コードの表示]をクリック、
表示された白いシート（ＶＢＥのシートモジュール）に
下記をコピペして
Alt + F11 キーでExcelに戻ります。

以降、A1から連続したセル範囲を書き換える度に、
右側、１列挟んで右側に、全通りの組合わせを
作成します。

' ' ここから

Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim rSrc As Range
　　Application.EnableEvents = False
　　Set rSrc = Range("B2").CurrentRegion
　　Application.EnableEvents = True
　　If Intersect(Target, rSrc) Is Nothing Then Exit Sub
　　Application.EnableEvents = False
　　Call PrintCombi(rSrc)
　　Application.EnableEvents = True
End Sub

Sub PrintCombi(ByVal rSrc As Range)
　　Dim tnFld As Long
　　Dim nRc As Long
　　Dim nConti As Long
　　Dim nRow As Long
　　Dim i As Long
　　Dim j As Long

　　tnFld = rSrc.Columns.Count
　　nConti = 1
　　With rSrc(1, rSrc.Columns.Count + 2)
　　　　.CurrentRegion.Clear
　　　　For i = tnFld To 1 Step -1
　　　　　　nRc = Cells(Rows.Count, i).End(xlUp).Row
　　　　　　nRow = 1
　　　　　　For j = 1 To nRc
　　　　　　　　Cells(j, i).Copy Destination:=.Cells(nRow, i).Resize(nConti)
　　　　　　　　nRow = nRow + nConti
　　　　　　Next j
　　　　　　nConti = nConti * nRc
　　　　Next i
　　　　With .Resize(nConti / nRc)
　　　　　　For i = 3 To tnFld
　　　　　　　　Range(.Cells(1, i), .Cells(1, i).End(xlDown)).Copy Destination:=.Columns(i)
　　　　　　Next i
　　　　End With
　　End With
End Sub

' ' ここまで

この回答への補足

cj_mover さま、ご回答ありがとうございます。
完璧にできました!!

恐れ入りますが追加希望がございまして。
1行目は項目を入れたいので、参照したくありません。
いただいたものを編集してみようと思ったのですが、スキがなくて、わかりません。。。。
2行目以降からスタートという風に書き換えるにはどうすればよろしいでしょうか？

またこの質問に気づいていただけることを祈って。

補足日時：2013/10/22 16:40