解決済み

足し算の組み合わせ

  • 困ってます
  • 質問No.7315244
  • 閲覧数629
  • ありがとう数5
  • 気になる数0
  • 回答数10
  • コメント数0

お礼率 44% (193/432)

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

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・・・xまで可変とし、系列数も可変とします。
ただし、すべての系列は同じです。
つまり、A系列=1,2,3、B系列=1,2,3,4ということはありません。
たとえば、A系列が1,2,3,4だったら、のこりの系列もすべて1,2,3,4です。

質問者が選んだベストアンサー

  • 回答No.9

ベストアンサー率 70% (1019/1451)

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

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

お礼率 44% (193/432)

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

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

結果をセルに書き出すことが最終目標ではないので問題ありませんが。
投稿日時 - 2012-02-21 23:12:42
感謝経済

その他の回答 (全9件)

  • 回答No.10

ベストアンサー率 70% (1019/1451)

>演算誤差を避けるために、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

ベストアンサー率 70% (1019/1451)

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

    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
にしてください。
補足コメント
dansin_Goo

お礼率 44% (193/432)

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

やはり重複が出ます。

たとえば、


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

の場合です。
投稿日時 - 2012-02-21 21:57:19
  • 回答No.7

ベストアンサー率 70% (1019/1451)

面白そうだったので

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ならクエリの直積であっという間の事なのですけど。
無理無理のごり押しコードですが、一応動きました。
ご参考まで。
補足コメント
dansin_Goo

お礼率 44% (193/432)

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

たとえば、

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:23
お礼コメント
dansin_Goo

お礼率 44% (193/432)

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

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

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

理解できないのでどこをどう修正したらよいかわかりません。
よろしくお願いいたします。
投稿日時 - 2012-02-21 21:01:14
  • 回答No.6

ベストアンサー率 52% (885/1701)

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

ベストアンサー率 49% (2537/5118)

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
補足コメント
dansin_Goo

お礼率 44% (193/432)

お礼の訂正です。


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


画像の例ですと、4データ×3系列
投稿日時 - 2012-02-20 23:17:39
お礼コメント
dansin_Goo

お礼率 44% (193/432)

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

画像の例ですと、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:49
  • 回答No.4

ベストアンサー率 52% (885/1701)

この手のものはループをたくさん回すことになるのでデータ数や系列数が大きくなるとやたら時間がかかるようになりますよ。
コード中の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
お礼コメント
dansin_Goo

お礼率 44% (193/432)

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

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

ためしに、
Dim nData() を、Dim nData() as double 
にしても駄目でした。
投稿日時 - 2012-02-20 22:22:35
  • 回答No.3

ベストアンサー率 49% (2537/5118)

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
お礼コメント
dansin_Goo

お礼率 44% (193/432)

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

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

パラメータ(系列数、系列のデータ)をどのように渡せばいいのでしょうか。
データはA1、B1,・・・のように入れていけばいいと思いますが、
系列数はどのように指定すればいいですか?
投稿日時 - 2012-02-20 22:19:45
  • 回答No.2

ベストアンサー率 49% (2537/5118)

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

ベストアンサー率 49% (2537/5118)

こんばんは!
一例です。
各系列は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
補足コメント
dansin_Goo

お礼率 44% (193/432)

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

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


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

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

よろしくお願いします。
投稿日時 - 2012-02-19 21:15:59
AIエージェント「あい」

こんにちは。AIエージェントの「あい」です。
あなたの悩みに、OKWAVE 3,500万件のQ&Aを分析して最適な回答をご提案します。

関連するQ&A
こんな書き方もあるよ!この情報は知ってる?あなたの知識を教えて!
このQ&Aにはまだコメントがありません。
あなたの思ったこと、知っていることをここにコメントしてみましょう。

その他の関連するQ&A、テーマをキーワードで探す

キーワードでQ&A、テーマを検索する

特集


感謝指数によるOK-チップ配布スタート!

ピックアップ

ページ先頭へ