エクセルVBA 組み合わせの列挙

例えば、整数型配列a(6)={1,2,3,4,5,6}があったとして、
この中から２つ取り出し、その積と、残りの４つの数の積を求める
マクロを作りたいと考えております。
具体的に言いますと、まず{1,2}を選んだとすると、セルA1に１×２＝２が入り、
セルB1に3×4×5×6＝360が入るようにしたいです。
同種の質問等を検索した結果、
２つ取り出すときの組み合わせは、再起処理で可能だとは思うのですが、
それと同時に、残り4つの数の積を求めるには、
どうのようにしたら良いのでしょうか？
組み合わせの求め方を含んだ形で、ご教授頂けたら幸いです。
よろしくお願いいたします。

No.4 ベストアンサー 回答者： WindFaller 回答日時： 2018/04/10 11:42

本当は、数学的に解決する方法があるだろうけれども、以下は、結構、ネット内では知られた古くからあるアルゴリズムです。

ただ、VBAの実務的には、#1さんの書かれた内容のほうが上なのでした。
以下は、一旦、組み合わせをアルゴリズムで作った後に、その残った補完数を羅列しただけで、後は、Product 関数で計算しました。単に、アルゴリズムにこだわっただけのコードです。

'//
Option Explicit
Sub MakingCombin()
Dim Stock As Variant
Dim i As Long
Dim r_PICK
r_PICK = 2 '抽出数
Stock = Array(1, 2, 3, 4, 5, 6) '配列ストック
ActiveSheet.UsedRange.ClearContents 'データを消す
'実行
Call sCombinations(Stock, r_PICK)
End Sub

Private Sub sCombinations(ByVal Stock, ByVal r As Long)
　Dim num As Long
　Dim ar As Variant
　Dim ar_sp As Variant
　Dim i As Long, j As Long
　Dim k As Long, t As Long
　Dim rOrg As Long

　rOrg = r 'もとの抽出数を保管
　num = UBound(Stock) - LBound(Stock)
　r = r - 1
　ReDim ar(0, r)
　ReDim ar_sp(0, num)
　Dim ar_compl 'もとの配列ストック
　Dim arTmp
　Dim idx() As Long
　ReDim idx(0 To r)

　For i = 0 To r
　　idx(i) = i
　Next i

　For i = 0 To UBound(Stock)
　　ar_sp(0, i) = Stock(i)
　Next
　 ar_compl = ar_sp
　Do
　　For j = r To 0 Step -1
　　　ar(0, j) = Stock(idx(j))
　　Next
　　arTmp = ar_compl
　　For i = 0 To UBound(idx): arTmp(0, idx(i)) = Null: Next i
　　ReDim ar_sp(0, UBound(Stock) - rOrg) '補完変数に移し替え
　　For i = 0 To UBound(Stock)
　　 If Not IsNull(arTmp(0, i)) Then
　　　 ar_sp(0, t) = arTmp(0, i)
　　　 t = t + 1
　　 End If
　　Next i
　　k = k + 1　　'書き出しの行
　　Cells(k, 1).Value = Application.Product(ar)
　　'Cells(k, 4).Resize(1, UBound(ar, 2) + 1).Value = ar '明細
　　Cells(k, 2).Value = Application.Product(ar_sp)
　　'Cells(k, UBound(ar, 2) + 5).Resize(1, UBound(ar_sp, 2) + 1).Value = ar_sp '明細
　　i = r: t = 0
　　While (idx(i) = num - r + i)
　　　i = i - 1
　　　If i = -1 Then
　　　　Exit Sub
　　　End If
　　Wend
　　idx(i) = idx(i) + 1
　　For j = i + 1 To r
　　　idx(j) = idx(i) + j - i
　　Next j
　　ar_sp = ar_compl
　Loop
End Sub

この回答へのお礼

ご回答ありがとうございます。
まさに私がやりたかった事です。
自分が考えていた、プログラムと全然違うので、
ものすごく勉強になりました。
誠にありがとうございました。

お礼日時：2018/04/10 22:16

No.5 回答者： moto_koukousei 回答日時： 2018/04/10 18:46

＞　配列aの大きさ、数値、取り出す個数を任意にしたかったため、

配列の大きさや個々の数値はともかく、取り出す個数を２ではなく、３，４のようにしたい場合は、２次元マトリクスは使えません。
マクロしかないような気がします。
No.4 WindFalleさんの回答のままです。　取り出す数値のみ追加表示

Option Explicit
Sub MakingCombin()
Dim Stock As Variant
Dim i As Long
Dim r_PICK
r_PICK = 4 '抽出数
Stock = Array(9, 11, 13, 4, 5, 6, 7, 8, 17) '配列ストック
ActiveSheet.UsedRange.ClearContents 'データを消す
'実行
Call sCombinations(Stock, r_PICK)
End Sub

Private Sub sCombinations(ByVal Stock, ByVal r As Long)
Dim num As Long
Dim ar As Variant
Dim ar_sp As Variant
Dim i As Long, j As Long
Dim k As Long, t As Long
Dim rOrg As Long

rOrg = r 'もとの抽出数を保管
num = UBound(Stock) - LBound(Stock)
r = r - 1
ReDim ar(0, r)
ReDim ar_sp(0, num)
Dim ar_compl 'もとの配列ストック
Dim arTmp
Dim idx() As Long
ReDim idx(0 To r)

For i = 0 To r
idx(i) = i
Next i

For i = 0 To UBound(Stock)
ar_sp(0, i) = Stock(i)
Next
ar_compl = ar_sp
Do
For j = r To 0 Step -1
ar(0, j) = Stock(idx(j))
Next
arTmp = ar_compl
For i = 0 To UBound(idx): arTmp(0, idx(i)) = Null: Next i
ReDim ar_sp(0, UBound(Stock) - rOrg) '補完変数に移し替え
For i = 0 To UBound(Stock)
If Not IsNull(arTmp(0, i)) Then
ar_sp(0, t) = arTmp(0, i)
t = t + 1
End If
Next i
k = k + 1 '書き出しの行
For i = 0 To r
Cells(k, 1 + i).Value = ar(0, i)
Next i
Cells(k, 2 + r).Value = Application.Product(ar)
Cells(k, 3 + r).Value = Application.Product(ar_sp)
i = r: t = 0
While (idx(i) = num - r + i)
i = i - 1
If i = -1 Then
Exit Sub
End If
Wend
idx(i) = idx(i) + 1
For j = i + 1 To r
idx(j) = idx(i) + j - i
Next j
ar_sp = ar_compl
Loop
End Sub

この回答へのお礼

早速のご回答ありがとうございます。
補足して頂き、大変助かりました。
この度は、誠にありがとうございました。

お礼日時：2018/04/10 22:23

No.3 回答者： moto_koukousei 回答日時： 2018/04/10 10:58

＞　セルB1に3×4×5×6＝360が入るように

残り4つの数の積を求めるには、つぎのようにしてはいかがでしょうか。
セルB1に3×4×5×6＝360が入るように
セルB1に１×２×3×4×5×6÷（１×２）＝360が入るように
セルB1に１×２×3×4×5×6÷（１×２）＝360が入るように
セルB1に（１×２×3×4×5×6）÷（１×２）＝360が入るように

どこかのセル(F1)に　（１×２×3×4×5×6）を入れておいて、
セルA1に（１×２）　　　セルB1に　F1÷A1
セルA2に（２×３）　　　セルB2に　F1÷A2
セルA3に（１×４）　　　セルB3に　F1÷A3
セルA4に（２×４）　　　セルB4に　F1÷A4

4つの数値の中に、同じ値の数値が含まれている場合もあるとして、VBAを使わなくて、エクセルシート上に、組み合わせのスコアボードを表示するという方法もあるように思います。

縦横のマトリクスをつくれば、２つの組み合わせがすべて表示されます。
対角線は相手なしになるので、数値は入りません。
左下の領域に、２つの組み合わせの乗算値を表示させ、
右上の領域に、2つの組み合わせ以外の数の乗算値を表示させます。
都合上、全部の数の乗算値をどこかに表示させておきます。
右上の領域の2つの組み合わせ以外の数の乗算値は、全部の数の乗算値を割って出します。
ほとんどコピーでできます。
B2　=INDEX($A$3:$A$18,COLUMN()-1)
B1　=B2*C2*D2*E2*F2*G2*H2*I2*J2*K2*L2
B4　=$A4*B$2
C3　=$B$1/C$2/$A3

この回答へのお礼

ご回答ありがとうございます。
なるほど、確かにおっしゃる通りです。

配列aの大きさ、数値、取り出す個数を任意にしたかったため、
VBAでの処理を考えていました。
その都度、処理していくしかないのでしょうか？

お礼日時：2018/04/10 13:31

No.2 回答者： めぐみん_ 回答日時： 2018/04/10 09:03

配列から選択した値をIndexで『1』に変更してしまい、全部をProduct関数で求めればよいのでは？

例えば今回の場合Index 0,1 が 1 になっている状態なので

Dim v

v = Array(1, 1, 3, 4, 5, 6)

MsgBox (Application.Product(v))

こんな感じでしょ。

あとは現在どのようになっているのかでも変わるでしょうけど、乱数でIndexを求めるなら 1 に変更するのも楽な気はしますけど。
ただ任意に選択してって事なら考え方として楽なのは配列の中を順次取得し比較して、選択した値と同じなら 1 に変えてしまうとかかな？

この回答へのお礼

ご回答ありがとうございます。
一度「１」に書き換えてから積を取って、
配列の数値をリセットして次の組み合わせを考えるということでしょうか？

お礼日時：2018/04/10 13:23

No.1 回答者： siffon9 回答日時： 2018/04/10 05:59

こんなかんじでしょうか。

扱う数値があまり大きくないのであれば
４つの積は、「６つの積 / i / j」 で求めても可ですね。

Sub test()
　　Dim a(1 To 6) As Long
　　Dim i As Long, j As Long, k As Long, v As Long
　　Dim mulAll As Long
　　Dim row As Long: row = 1
　　
　　'ここでa(1)～a(6)に値を書き込む
　　
　　For i = LBound(a) To UBound(a) - 1
　　　　For j = i + 1 To UBound(a)
　　　　　　Cells(row, "A").Value = a(i) * a(j)' 2つの積を書く
　　　　　　v = 1
　　　　　　For k = LBound(a) To UBound(a)
　　　　　　　　If k <> i And k <> j Then ' a(i),a(j)以外の4つの積を求める
　　　　　　　　　　v = v * a(k)
　　　　　　　　End If
　　　　　　Next
　　　　　　Cells(row, "B").Value = v ' 4つの積を書く
　　　　　　row = row + 1
　　　　Next
　　Next
End Sub

この回答へのお礼

ご回答ありがとうございます。
扱う数値、配列の大きさは大きくないので、
ご教授頂いた方法で処理できそうです。

後だしになってしまい申し訳ないのですが、
３つ取り出して、残り３つ、4つ取り出して残り２つ、
５つ取り出して、残り１つというように、
取り出す個数を変更しつつ、すべての結果を得るためには、
IFで条件分岐させていく形になるのでしょうか？

お礼日時：2018/04/10 13:16