エクセル・解がある数字になるように足し算する数字を選ぶ方法

質問

いくつかの数字が並んでいて、その中から選んで足し算をします。
その足し算の答えがある範囲内に当てはまるような組み合わせを全部求めたいと思います。

分かりにくいので具体例を書きます。
0.5
1.1
1.8
2.3
3.8
4.2

上記の６個の数字からいくつか選んで足した結果が4.9～5.9になる組み合わせをすべて求めたいです。
この場合、
0.5+1.1+1.8+2.3＝5.7
1.1+1.8+2.3＝5.2
4.2+0.5＝4.7
4.2+1.1＝5.3
4.2+1.1+0.5＝5.8
3.8+1.8＝5.6
3.8+1.1＝4.9
3.8+1.1+0.5＝5.4
の８種類（もっとあったらごめんなさい）になると思います。
この８種類を書き出したいのですが、うまい方法が思い浮かびません。

ソルバーとかなのかと思って調べてみたのですが、計算式が確定していない場合は使えないみたいです。
やっぱりＶＢＡを使わないと難しいでしょうか？

なんとか簡単にできる方法があれば、アドバイス下さい。
よろしくお願いいたします。

回答No.2

lark_0925 · ベストアンサー

>上記の６個の数字からいくつか選んで足した結果が4.9～5.9になる組み合わせをすべて求めたいです。

なら、
4.2+0.5＝4.7
これは、範囲外だよね！！

組合せの最適化をすれば、もっと速いコードもありそうですが・・・。
新規ブックの標準モジュール（Module1）に
'========================================================
Sub main()
　Dim 組合せセル範囲 As Range
　Dim 抜き取り数 As Long
　Dim asum As Double
　Dim 合計1 As Double
　Dim 合計2 As Double
　Dim d_rw As Long
　Range("a1:a6").Value = [{0.5;1.1;1.8;2.3;3.8;4.2}]
　MsgBox "サンプルデータをＡ列に設定"

　合計1 = 4.9
　合計2 = 5.9

　d_rw = 1
　Set 組合せセル範囲 = Range("a1", Cells(Rows.Count, "a").End(xlUp))
　組合せセル範囲.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo
　For 抜き取り数 = 1 To 組合せセル範囲.Count
　　　Call init_comb(組合せセル範囲, 抜き取り数)
　　　ReDim ans(1 To 抜き取り数)
　　　Do While get_comb(ans()) = 0
　　　　asum = Application.Sum(ans())
　　　　If asum >= 合計1 And asum <= 合計2 Then
　　　　　　Range(Cells(d_rw, 3), Cells(d_rw, 抜き取り数 + 2)).Value = ans()
　　　　　　d_rw = d_rw + 1
　　　　ElseIf asum > 合計2 Then
　　　　　　skip_comb
　　　　　　End If
　　　　Loop
　　　Next
　MsgBox "以上、" & d_rw - 1 & "　通り検出しました"
End Sub

別の標準モジュールに（Module2）に
組合せリスト作成ルーチン
'===========================================================
Option Explicit
　　Private c_svn As Long '抜き取り数保存
　　Private c_myarray() '組合せ対象値の配列
　　Private c_idx() As Long '配列のカレントポインタ
　　Private cs_x() As Long '配列の基盤ポインタ
'=======================================
Function init_comb(rng As Range, seln As Long) As Double
　　Dim i As Long
　　Dim crng As Range
　　c_svn = seln
　　Erase c_myarray()
　　Erase c_idx()
　　Erase cs_x()
　　i = 1
　　ReDim Preserve c_myarray(1 To rng.Count)
　　For Each crng In rng
　　　c_myarray(i) = crng.Value
　　　i = i + 1
　　　Next
　　ReDim cs_x(1 To seln)
　　ReDim c_idx(1 To seln)
　　For i = 1 To UBound(c_idx())
　　　cs_x(i) = i
　　　c_idx(i) = i
　　　Next
　　c_idx(UBound(c_idx())) = c_idx(UBound(c_idx())) - 1
　　init_comb = WorksheetFunction.Combin(rng.Count, seln)
End Function
'=======================================
Function get_comb(ans()) As Long
　　Dim i As Long
　　Dim j As Long
　　get_comb = 1
　　For i = UBound(c_idx()) To LBound(c_idx()) Step -1
　　　If c_idx(i) + 1 <= UBound(c_myarray()) - c_svn + i Then
　　　　　c_idx(i) = c_idx(i) + 1
　　　　　get_comb = 0
　　　　　Exit For
　　　Else
　　　　　c_idx(i) = cs_x(i) + 1
　　　　　cs_x(i) = cs_x(i) + 1
　　　　　For j = i + 1 To UBound(cs_x())
　　　　　　cs_x(j) = cs_x(j - 1) + 1
　　　　　　c_idx(j) = cs_x(j)
　　　　　　Next j
　　　　　End If
　　　Next
　　If get_comb = 0 Then
　　　For i = LBound(c_idx()) To UBound(c_idx())
　　　　　ans(i) = c_myarray(c_idx(i))
　　　　　Next
　　　End If
End Function
'=======================================
Function skip_comb()
　　Dim i As Long
　　For i = UBound(c_idx()) To LBound(c_idx()) + 1 Step -1
　　　If c_idx(i) <> c_idx(i - 1) + 1 Then
　　　　　c_idx(i) = UBound(c_myarray()) - c_svn + i
　　　　　Exit For
　　　　　End If
　　　c_idx(i) = UBound(c_myarray()) - c_svn + i
　　　Next
End Function
'=======================================
Sub close_comb()
　　Erase c_myarray()
　　Erase c_idx()
　　Erase cs_x()
End Sub

として、適当なシート（何も入力されていない）でmainを
実行してみてください。セルＣ１から条件にあった組合せを
表示します。

お礼

ありがとうございますー（Ｔ－Ｔ）
おっしゃるとおり、4.7は範囲外でした（＾－＾；

lark_0925様にいただいたコードを使ってみたら、理想通りの結果を得ることができました！
総当たりで足し算をしたとしても、その足している数字が何なのかを全部書き出すにはどうすれば…と思っていましたが、配列を利用すれば良かったのですね！
配列はなかなか難しくて、自分では使いこなせないのですが、lark_0925様のコードを見てなんとか理解しようと思います。

個人的には「Application.Sum(ans())」で合計を取れるということに感動しました！

それにしてもすごいですね！！！
こんなすぐにコードをかけてしまうなんて、尊敬です。
本当にとてもとても助かりました。
涙が出るほど嬉しいです。本当にありがとうございました。

回答No.4

NNAQ

数個なら。。。

A列にデータがあって、作業列が X～Z列だとして、
　　　X　　　Y　　　Z
1　　　　　　　　　　001010
2　000001　 4.2　　010001
3　000010　 3.8　　010010
4　000011　 8　　　011100
5　000100　 2.3　　110001
6　000101　 6.5　　110010
7　000110　 6.1　　111100
：
X2=TEXT(DEC2BIN(ROW(A1)),REPT("0",6))
X64までコピー(64=2^6)。
Y2=SUMPRODUCT($A$1:$A$6,MID(X2,ROW($A$1:$A$6),1)*1)
Y64までコピー。

Y列にオートフィルターで　[4.9以上]AND[5.9以下]　の条件で抽出。
抽出されたX列のデータをコピー、Z1に[形式を選択して貼り付け]-[値]。

　　A　　　B　　C　　・・・
1　0.5　　0　　0
2　1.1　 0　　1
3　1.8　 1　　0
4　2.3　 0　　0
5　3.8　 1　　0
6　4.2　 0　　1
7　　　　5.6　　5.3

B1=MID(INDEX($Z:$Z,COLUMN(A1)),ROW(A1),1)*1
B6までと、右へコピー。
B7=SUMPRODUCT($A1:$A6,B1:B6)
右へコピー。

1と0 で、その数字を使う使わない の判定にします。7行目は確認用。
B列は　1.8 + 3.8 = 5.6
C列は　1.1 + 4.2 = 5.3
という意味です。

VBA でやるなら、２つ足す場合、３つ足す場合、４つ足す場合・・・
と、やると、遅くなると思います。
総当りはどんな方法でも限界があるでしょうけど。

'データは、A1セルから空白無く、複数あるとする
Sub SoAtari()
　'目標値
　Const a As Currency = 4.9 '以上
　Const z As Currency = 5.9 '以下

　Dim n As Integer 'データ数
　Dim arr0, arr1() As Currency
　Dim b As Long
　Dim i As Long, j As Long 'ループ用、使い回し
　Dim col As Integer '列番号

　With Range("a1")
　　n = .End(xlDown).Row
　　arr0 = .Resize(n).Value
　　.CurrentRegion.Offset(, 1).ClearContents
　End With

　'全ての組み合わせの和を配列arr1にセット
　'全て計算する必要は無いので、改善の余地あり
　ReDim arr1(1 To 2 ^ n - 1)
　For i = 0 To n - 1
　　b = 2 ^ i
　　arr1(b) = CCur(arr0(i + 1, 1))
　　For j = 1 To b - 1
　　　arr1(b + j) = arr1(b) + arr1(j)
　　Next j
　Next i

　col = 2
　For i = 1 To 2 ^ n - 1
　　'目標値の範囲ならシートへ書き込む
　　If arr1(i) >= a And arr1(i) <= z Then
　　　For j = 0 To n - 1
　　　　If i And 2 ^ j Then Cells(j + 1, col).Value = arr0(j + 1, 1)
　　　Next j
　　　Cells(n + 1, col).Value = CDbl(arr1(i))
　　　col = col + 1
　　End If
　Next i

　Erase arr0, arr1
End Sub

お礼

ありがとうございます！
すごい！！関数でもできるんですね。
０と１を使って使うかどうかの判定をしたり、それを組み合わせで全通り表示する方法など、たぶん一生考えても思いつけそうにありません。
感動しました（Ｔ－Ｔ）
９個まではちゃんとできました！
１０個からは２進数が表示されないみたいでエラーになってしまいました。

ＶＢＡの改善とは、上限を超えた場合は計算をしなくても良いということですよね。
でも、試しに動かしてみたら速度に問題なく計算できました！！
結果が一覧になっていてとても見やすかったです。
とてもとても勉強になりました。
やはり配列はちゃんと勉強すればとても役立つのだと思いました。
ありがとうございました！！大感謝です。

回答No.3

lark_0925

追伸　Ａ列のデータは、昇順に整列されているものとします。

お礼

了解しました。

回答No.1

n-jun

類似していると言えば、
http://okwave.jp/qa257719.html
でしょうか。
ただ固定された答えではなく範囲内に入る組み合わせとなると、
もっとやっかいになるように思います。

回答ではなく、すいません。

お礼

本当にやっかいで、私一人ではどうにも解けず、ここに相談してみました。
ご回答ありがとうございます（＾－＾）