足し算の組み合わせ

組み合わせの足し算について質問します。

1,2,3という数字があったとします。
たとえば、この1,2,3を2系列用意し、それぞれ足します。
考えやすくするため、2系列を次のようにあらわします。
A系列=1,2,3
B系列=1,2,3
また、A系列の1をA1、B系列の2をB2などのように表現します。


考えられる組み合わせの足し算は次のようになります。
A1+B1=2
A1+B2=3
A1+B3=4
A2+B1=3
A2+B2=4
A2+B3=5
A3+B1=4
A3+B2=5
A3+B3=6

そして、ここから重複を排除すると、残る足し算の結果は、

2,3,4,5,6となります。

これをVBAでプログラミングしたいのですが、どのように考えればよいでしょうか。
もちろん、実際は、1,2,3・・・ｘまで可変とし、系列数も可変とします。
ただし、すべての系列は同じです。
つまり、A系列=1,2,3、B系列=1,2,3,4ということはありません。
たとえば、A系列が1,2,3,4だったら、のこりの系列もすべて1,2,3,4です。

No.9 ベストアンサー 回答者： nicotinism 回答日時： 2012/02/21 22:53

Private aryOrg As Variant

Private aryTmp As Variant

Sub main()
Const rp = 3 '系列数
aryOrg = Array(0, 1.1, 2.2, 3.3, 4.4, 5.5)
　　Dim aryRes() As Variant
　　Dim i As Long, j As Long, k As Long
　　Dim myMatch As Boolean
　　
　　aryTmp = aryOrg
　　
　　'全ての組み合わせを再帰的に取得
　　For i = 1 To rp - 1
　　　　Call subR(aryTmp)
　　Next
　　
　　'重複を排除し配列に格納
　　ReDim aryRes(0)
　　For i = 0 To UBound(aryTmp)
　　　　
　　　　myMatch = False
　　　　For k = 0 To UBound(aryRes)
　　　　　　If IsEmpty(aryRes(k)) = False And aryRes(k) = aryTmp(i) Then
　　　　　　　　myMatch = True
　　　　　　End If
　　　　Next
　　
　　　　If myMatch = False Then
　　　　　　aryRes(j) = aryTmp(i)
　　　　　　j = j + 1
　　　　　　ReDim Preserve aryRes(j)
　　　　End If
　　Next
　　
　　For i = 0 To UBound(aryRes)
　　　　Debug.Print aryRes(i)
　　Next
End Sub

Sub subR(ByVal aryR As Variant)
　　Dim i As Long, j As Long, k As Long
　　
　　ReDim aryTmp((UBound(aryR) + 1) * (UBound(aryOrg) + 1) - 1)
　　For i = 0 To UBound(aryR)
　　　　For j = 0 To UBound(aryOrg)
　　　　　　aryTmp(k) = CCur(aryR(i) + aryOrg(j))
　　　　　　k = k + 1
　　　　Next
　　Next
End Sub

小数点以下下４桁までの倍精度浮動小数点型の演算誤差を保証しています。
もうボロが出ませんように。

この回答への補足

すばらしいです。
たぶんもう大丈夫です。

でも、なぜか結果をセルに出力したとき、\マークが表示される
用になってしまいましたが…(笑)

結果をセルに書き出すことが最終目標ではないので問題ありませんが。

補足日時：2012/02/21 23:12

No.10 回答者： nicotinism 回答日時： 2012/02/22 23:40

>演算誤差を避けるために、Ccur 関数で通貨型に変更しているためです。

たとえば、イミディエイトウィンドウで
?2.2+2.2+2.2=0+3.3+3.3
とすると、False（左辺と右辺が異なる）が返ります。
?1.2-0.2-1
だと0にはならずに
-5.55111512312578E-17

これを避けるためにCcur関数を使用しています。
分かりやすい説明がこちらにあります。時間を割いてご覧ください。
http://pc.nikkeibp.co.jp/pc21/special/gosa/

No.8 回答者： nicotinism 回答日時： 2012/02/21 21:47

さっそくボロが出た (＾＾ゞ

　　　　myMatch = False
　　　　For k = 0 To UBound(aryRes)
　　　　　　If aryRes(k) = aryTmp(i) Then
　　　　　　　　myMatch = True
　　　　　　End If
　　　　Next
のところを
　　　　myMatch = False
　　　　For k = 0 To UBound(aryRes)
　　　　　　If IsEmpty(aryRes(k)) = False And aryRes(k) = aryTmp(i) Then
　　　　　　　　myMatch = True
　　　　　　End If
　　　　Next
にしてください。

この回答への補足

何度もありがとうございます。

やはり重複が出ます。

たとえば、


Const rp = 3 '系列数
aryOrg = Array(0, 1.1, 2.2, 3.3, 4.4, 5.5)

の場合です。

補足日時：2012/02/21 21:57

No.7 回答者： nicotinism 回答日時： 2012/02/21 01:26

面白そうだったので

Option Explicit
Private aryOrg As Variant
Private aryTmp As Variant

Sub main()
　　Const rp = 3 '系列数
　　aryOrg = Array(1, 2, 3, 4, 5) '種データ
　　Dim aryRes() As Variant
　　Dim i As Long, j As Long, k As Long
　　Dim myMatch As Boolean
　　
　　aryTmp = aryOrg
　　
　　'全ての組み合わせを再帰的に取得
　　For i = 1 To rp - 1
　　　　Call subR(aryTmp)
　　Next
　　
　　'重複を排除し配列に格納
　　ReDim aryRes(0)
　　For i = 0 To UBound(aryTmp)
　　　　
　　　　myMatch = False
　　　　For k = 0 To UBound(aryRes)
　　　　　　If aryRes(k) = aryTmp(i) Then
　　　　　　　　myMatch = True
　　　　　　End If
　　　　Next
　　
　　　　If myMatch = False Then
　　　　　　aryRes(j) = aryTmp(i)
　　　　　　j = j + 1
　　　　　　ReDim Preserve aryRes(j)
　　　　End If
　　Next
　　
　　For i = 0 To UBound(aryRes)
　　　　Debug.Print aryRes(i)
　　Next
End Sub

Sub subR(ByVal aryR As Variant)
　　Dim i As Long, j As Long, k As Long
　　
　　ReDim aryTmp((UBound(aryR) + 1) * (UBound(aryOrg) + 1) - 1)
　　For i = 0 To UBound(aryR)
　　　　For j = 0 To UBound(aryOrg)
　　　　　　aryTmp(k) = aryR(i) + aryOrg(j)
　　'　　　　Debug.Print k, aryTmp(k)
　　　　　　k = k + 1
　　　　Next
　　Next
End Sub

Accessならクエリの直積であっという間の事なのですけど。
無理無理のごり押しコードですが、一応動きました。
ご参考まで。

この回答への補足

よく調べたら、不完全でした。
おそらく、整数のみでしたら問題なさそうですが、小数交じりだと重複が多数発生しました。

たとえば、

Const rp = 3 '系列数
aryOrg = Array(1.1, 2.2, 3.3, 4.4) '種データ

とし、
最後の部分のForを

For i = 0 To UBound(aryRes)
Debug.Print aryRes(i)
Cells(i + 1, 1) = aryRes(i)
Next

として結果をセルに書き出すようにして実行すると、
重複された結果が出てしまいます。

やはり、小数が入ると難しいのでしょうか。

補足日時：2012/02/21 21:26

この回答へのお礼

回答ありがとうございます。
すばらしいの一言です。

理解の範囲を完全に逸脱していますが、何とか実行することができました。
ほぼ、希望の動作どおりですが、データに0が入っているときに、結果に0が出力され
ませんでした。

たとえば、0,1,2,3を種データとした場合、結果の一番上は0となるはずですが・・・

理解できないのでどこをどう修正したらよいかわかりません。
よろしくお願いいたします。

お礼日時：2012/02/21 21:01

No.6 回答者： mt2008 回答日時： 2012/02/21 00:54

ANo.4です。

> 正直、自分の理解の範囲を超えているのですが、データを
> 小数に対応するにはどうすればいいのでしょうか。

私のやり方では少数には対応できません。
この方法は、足し算した時の最大値（例：6）を求め、0～最大値までの配列を用意（nSum(0)～nSum(6)）。ループを回して全パターンの足し算を実行し、その答えの番の配列にTrueを入れています（足し算の答え：2→nSum(2)=True）。
で、最後に配列の内、Trueになっている物だけを抜き出しています。
nSum(0)=False
nSum(1)=False
nSum(2)=True
nSum(3)=True
nSum(4)=True
nSum(5)=True
nSum(6)=True
　↓
2,3,4,5,6

つまり、足し算の答えが少数になることは想定していません。
答えが小数点以下2桁等に決まっているのなら100倍等して整数にすることで対応はできます。

No.5 回答者： tom04 回答日時： 2012/02/20 22:55

No.2・3です。

おそらく当方の勘違いのような気がします。
Sheet1が↓の画像のような配置になっていて、
すべての列毎の組み合わせの和で、重複しないものをSheet2のA列に表示するようなコードでした。

画像で説明すると
1+5 1+6 1+7 1+8 2+5 2+6 2+7 2+8 ・・・4+7 4+8
5+9 5+10 5+11 5+12 6+9 6+10 6+11 ・・・8+11 8+12
とすべての和をSheet2A列に表示させ、重複分を削除・昇順に並び替え！

という内容でした。

※　系列等を考えず、単にSheet1の表を順に舐めるように加えているだけです。
（何列あっても対応できるように・・・）

的外れならごめんなさいね。m(_ _)m

この回答への補足

お礼の訂正です。

誤
＞画像の例ですと、3データ×3系列

正
画像の例ですと、4データ×3系列

補足日時：2012/02/20 23:17

この回答へのお礼

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

画像の例ですと、3データ×3系列ですので、足し合わせる数も3つずつになります。
縦を系列のデータ、横を系列と考えると、
ほしい結果は、
1+5+9
1+5+10
1+5+11
1+5+12
1+6+9
1+6+10
1+6+11
1+6+12
1+7+9
・・・
4+8+11
4+8+12

で、これらすべての結果から重複を排除したいのです。

よろしくお願いします。

お礼日時：2012/02/20 23:13

No.4 回答者： mt2008 回答日時： 2012/02/20 15:34

この手のものはループをたくさん回すことになるのでデータ数や系列数が大きくなるとやたら時間がかかるようになりますよ。

コード中のnData にデータを、nKeiretsu　に系列数を入れてください。
結果は配列でほしいとの事ですが、わかりやすくするため、A列にも吐き出しています。

Sub Sample()
　　Dim nData()
　　Dim nKeiretsu, nIndex, nMax, nRtn, nPos, i, j, k
　　Dim nSum() As Boolean
　　Dim nReturn() As Long '結果が入る配列

　　nData = Array(1, 2, 3) '←データ
　　nKeiretsu = 2 '←系列数

　　nIndex = UBound(nData) + 1
　　nMax = Application.WorksheetFunction.Max(nData) * nKeiretsu
　　ReDim nSum(nMax)

　　For i = 1 To (nIndex ^ nKeiretsu)
　　　　nRtn = 0
　　　　For j = 0 To (nKeiretsu - 1)
　　　　　　nTarget = 1 + Application.WorksheetFunction.RoundUp((i + 1 * (j = 0)) / (nIndex ^ j), 0) Mod nIndex
　　　　　　nRtn = nRtn + nData(nTarget - 1)
　　　　Next j
　　　　nSum(nRtn) = True
　　Next i

　　'結果を配列に
　　nPos = 0
　　For k = 0 To nMax
　　　　If nSum(k) = True Then
　　　　　　ReDim Preserve nReturn(nPos)
　　　　　　nReturn(nPos) = k
　　　　　　nPos = nPos + 1
　　　　End If
　　Next k
　　
　　'配列の結果をA列に表示（ついで）
　　For i = 1 To nPos
　　　　Cells(i, 1) = nReturn(i - 1)
　　Next i
End Sub

この回答へのお礼

回答ありがとうございます。
一番自分の希望のコードに近い感じです。

正直、自分の理解の範囲を超えているのですが、データを
小数に対応するにはどうすればいいのでしょうか。

ためしに、
Dim nData()　を、Dim nData() as double　
にしても駄目でした。

お礼日時：2012/02/20 22:22

No.3 回答者： tom04 回答日時： 2012/02/20 00:03

No.1・2です！

何度もごめんなさい。

前回（No.2）のコードで間違いがありました。
もう一度訂正させてください。
そして、余計なお世話かもしれませんが、Sheet2の表示を昇順にしてみました。

Sub test()
Dim i, j, k, L, M As Long
Dim ws As Worksheet
Set ws = Worksheets(2)
Application.ScreenUpdating = False
ws.Columns(1).ClearContents
M = Cells(1, Columns.Count).End(xlToLeft).Column
For j = 1 To M - 1
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
For k = j + 1 To M
For L = 1 To Cells(Rows.Count, 1).End(xlUp).Row
ws.Cells(Rows.Count, 1).End(xlUp).Offset(1) = Cells(i, j) + Cells(L, k)
Next L
Next k
Next i
Next j
For i = ws.Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If WorksheetFunction.CountIf(ws.Columns(1), ws.Cells(i, 1)) > 1 Then
ws.Cells(i, 1).Delete (xlUp)
End If
Next i
ws.Cells(1, 1).Delete (xlUp)
ws.Columns(1).Sort key1:=ws.Cells(1, 1), order1:=xlAscending
Application.ScreenUpdating = True
End Sub

今度はお役にたてますかね？m(_ _)m

この回答へのお礼

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

少々自分の理解の範囲を超えているのですが、これは系列数、
系列のデータ数の可変に対応しているのでしょうか？

パラメータ（系列数、系列のデータ）をどのように渡せばいいのでしょうか。
データはA1、B1,・・・のように入れていけばいいと思いますが、
系列数はどのように指定すればいいですか？

お礼日時：2012/02/20 22:19

No.2 回答者： tom04 回答日時： 2012/02/19 22:34

No.1です！

たびたびごめんなさい。

前回は質問内容を取り違えていたようでごめんなさい。
今回はSheet1のデータをSheet2のA列に表示するようにしてみました。

Sheet1のデータはA1セルから入っているとします。

Sub test()
Dim i, j, k, L, M As Long
Dim ws As Worksheet
Set ws = Worksheets(2)
Application.ScreenUpdating = False
ws.Columns(1).ClearContents
M = Cells(1, Columns.Count).End(xlToLeft).Column
For j = 1 To M - 1
For k = 2 To M
For L = 1 To Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
ws.Cells(Rows.Count, 1).End(xlUp).Offset(1) = Cells(i, j) + Cells(L, k)
Next i
Next L
Next k
Next j
For i = ws.Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If WorksheetFunction.CountIf(ws.Columns(1), ws.Cells(i, 1)) > 1 Then
ws.Cells(i, 1).Delete (xlUp)
End If
Next i
ws.Cells(1, 1).Delete (xlUp)
Application.ScreenUpdating = True
End Sub

こんな感じではどうでしょうか？
※　検証していませんので、ご希望通りでなかったら
ごめんなさいね。m(_ _)m

No.1 回答者： tom04 回答日時： 2012/02/19 21:07

こんばんは！

一例です。
各系列はA・B列の1行目からあり、結果をC1セル以降に表示させるとします。

Sub test()
Dim i, j As Long
Application.ScreenUpdating = False
Columns(3).ClearContents
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To Cells(Rows.Count, 2).End(xlUp).Row
Cells(Rows.Count, 3).End(xlUp).Offset(1) = Cells(i, 1) + Cells(j, 2)
Next j
Next i
For i = Cells(Rows.Count, 3).End(xlUp).Row To 2 Step -1
If WorksheetFunction.CountIf(Range(Cells(2, 3), Cells(i, 3)), Cells(i, 3)) > 1 Then
Cells(i, 3).Delete (xlUp)
End If
Next i
Cells(1, 3).Delete (xlUp)
Application.ScreenUpdating = True
End Sub

※　A・B列のデータ数が違っても対応できると思います。

他に良い方法があればごめんなさいね。m(_ _)m

この回答への補足

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

書き忘れて申し訳ありませんでしたが、系列が2個なら(限定されていれば)自分でも
記述できます。
ただし、限定されているからといって、系列が2個や3個程度ならForの入れ子を2個、3個で
すみますが、5個10個それ以上になると現実的ではありません。


系列数は動的にしたいのです。
系列内の数字（1,2,3など）はある程度決まっているのですが…。

できればセルにいちいち書き出さず、配列などを利用して実現できないかと考えています。

よろしくお願いします。

補足日時：2012/02/19 21:15