エクセルで、「袋詰め問題」を解きたい

質問

先週、数学カテゴリで質問させていただいたのですが、解を導きだすのに手計算では無理があるので、コンピュータにまかせたほうがいいというアドバイスをいただきました。

たとえば、ここに１３個の数値があります。

999,000
735,000
429,996
299,470
407,862
237,405
251,492
194,118
253,023
352,800
92,432
133,875
221,812

このなかの任意の数の和が、2,476,620になる数値を選びだしたいと思っています。
（毎月、各数値と候補となる数値の個数（例では１３個）、和の合計は変化します。）
業務上必要となるのですが、こういった流れをくむ問題の解を、瞬時に計算してくれる式は、エクセル等で組めるのでしょうか？関数というより、プログラミングレベルなのかもしれませんが、プログラムについて全然詳しくないので、言語と使用環境の関係がよくわかりません。ですのでエクセルを使用して作業することができればと思っています。
候補となる数値の個数は最大でも１５個くらいかと思います。
わざわざお金を出してプログラムを作成するまで規模も使用頻度もなく、かといって手計算では組み合わせの確率的にいって無理があるので、何とかオフィスソフト使用により自分で処理したいところです。知識のあるかたのご教授をお願いできたらと思っています。よろしくお願いいたします。

回答No.7

matsu_jun · ベストアンサー

#3、#5のmatsu_junです。ご利用ありがとうございました(笑)

○このプログラムで選び出せる数値の範囲はどのくらいまでなのでしょうか？

理論的には65536個まで、つまりA列全部利用できます(ひょっとしたら一番下の行だけは利用できなかったかもしれません)。また、「A列に入力した正の値の総和」の上限が約1.8×10の308乗、「A列に入力した負の数の総和」の下限が約-1.8×10の308乗までとなりますが、1つのセルに入力可能な値の上限が9.9×10の307乗までというExcelの仕様があるようです。どちらにしてもまず使わない話でしょう。というわけで、目標値の上下限は、セルに入力可能な値の上下限に等しい、プラスマイナス9.9×10の307乗ということですね。
つまり、普通に考えられる数字であれば、(負数や小数であっても問題なく)利用できるはずです。
あとは、私のミスもあるのですが、今のままでは同じ和の組合せが127種類を超えてしまうと、計算途中でも処理を終了してしまいます。
　If ResWrtCol > 256 Then '256列を超えてしまうと書き込めないので終了
　　MsgBox ("候補が多すぎるので終了します")
　　GoTo ERREND
　End If
の4行を
If ResWrtCol > 256 Then ResWrtCol = ResWrtCol - 2
という1行のものに書き換えておけば、とりあえず終了せずに処理を終えます。その代わり「IU列、IV列」(Excelで記入可能な最右列)に書き込まれたデータのみ、いい加減なものになります
まあよっぽどA列に規則正しいデータ(例えば全ての行に同じ値を入力するなど)を入れなければ候補が127個を超えることはないでしょうから、そのままでも多分問題ないと思いますが。

「実務レベルではどれだけ・・・」ということですが、難しい質問ですね。マシンスピードとあなたの忍耐力によって変わりますから。ただ、数字を入力するセル数が1つ増える毎に大体2倍くらいずつ時間がかかりますので、仮に15個のデータ処理に15秒かかったとすると、16個では30秒、17個では1分、18個では2分・・・と倍々で増えてゆきます。

出力された結果(目標値との差や行数が表示されること)にご満足頂いているようですが、上で示した処理時間からも分かるように、実は私のプログラムは数学的には駄作と言わざるを得ないものです。何せありうる全ての組合せを下から順に総ざらいして、そこから最も目標値に近いものを選び出すということをしているだけですので。どうか学習なさって、より高速に値の求まるアルゴリズムを見つけてください。

○VBAを開くのがはじめてだったので、・・・(中略)・・・削除したいのですが、これはモジュールの解放、という項目がそれにあたるのでしょうか？

見てみないとはっきりとはいえませんが、もしMicrosoft Visual Basicウィンドウの左側にある「プロジェクト」ウィンドウの「VBAProject(ご利用のブック名)というところの下の「標準モジュール」に「Module1」から「Module3」まで3つのアイコンができてしまったということなら、おっしゃるとおりの操作(不要なモジュール上で右クリック、「Module○○の開放」)でOKです。間違って正しいコードを書き込んだモジュールを開放しないで下さいね。あと開放する際、「削除する前にModule○をエクスポートしますか?」と聞かれると思いますが、「いいえ」を選んでもらって結構です。どうせ検証途中の不要なモジュールですから、潔く捨てちゃいましょう。

お礼

matsu_jun様、ご丁寧にどうもありがとうございます。
私の業務レベルでは訂正する必要もなく利用させていただくことができそうです。ヘタに訂正して大事な成功プログラムをへんてこりんにしてしまったら大変ですから。このまま大事にとっておこうと思います。モジュールの解放、問題なくひとつに絞り込むことができました。今日はじめてＶＢＡを開いたようなものでしたが、導入部分まで丁寧に指導してくださったおかげでなんとか実行することができました。ＶＢＡには興味があったのですが、プログラムという時点でムリだろうと思っていたのです。これをきっかけに、まずは「ビープ音」を鳴らす、というような小さなものからヒマをみて慣れていこうと思います。
本当にありがとうございました！

回答No.6

thisis2wakei

No.1の補足です。
各列（B～Q）の上に2のn乗を1,2,4,8,16,…,32768と順番に記述して、
たとえば、562を2進数に直す場合、
32768では割れないので、0
16384では割れないので、0
8192では割れないので、0
4096では割れないので、0
2048では割れないので、0
1024では割れないので、0
512では割れるので、1
上が1の場合は、次からは、562-512=50を割ってみる。
256では割れないので、0
128では割れないので、0
64では割れないので、0
32では割れるので、1
上が1の場合は、次からは、50-32=18を割ってみる。
16では割れるので、1
上が1の場合は、次からは、18-16=2を割ってみる。
8では割れないので、0
4では割れないので、0
2では割れるので、1
上が1の場合は、次からは、2-2=0を割ってみる。
1では割れないので、0
結果、
A列に562、各列には、1or0が入ってることになりますよね？
ちなみに32768（MAX）の場合は、
32768,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1
となり、B～PはALLゼロ。
32767（MAX-1）の場合は、
32768,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0
となり、B～PはALL１。
です。
VBAが組めるようになっても、こういう基本的なまわし方を常に考えるようにすると、応用の利くプログラムが書けるようになりますよ。
ちょっと偉そうか（笑）

お礼

詳しい補足まで、わざわざありがとうございます。以前数学カテゴリで質問した際に、２で割った余りが・・・というような考え方があると軽く教えてくださった方がいたのですが、その時はなぜそのような操作をする意味が理解てきなかったんです。それが上記のようなことだったんだと理解することができました。プログラムを提示していただいたのを実行してそれでおしまい、じゃ、全然進歩がありませんし、教えていただいた皆さんに失礼というものですよね。
この問題がナップザック問題という有名な問題であること、その性質、加えてVBAを起動して実行させる、というようなことまでたくさん教えていただきました。本当に感謝しています。ありがとうございます。

回答No.5

matsu_jun

#3のmatsu_junです。
ご指摘のとおり、「Sub 袋詰問題()」と最下行の「End Sub」が重複していますね。
最上行と最下行を削除して再度実行してみてください。

補足

できた、できました！選び出した数が何行目なのかまでわかるのですね。目標値との差まで出るなんて、素晴らしいです！わざわざ組んでいただいたのですね。本当にありがとうございます！！！
念のため確認させていただきたいのですが、
○このプログラムで選び出せる数値の範囲はどのくらいまでなのでしょうか？実務レベルではmatsu_junさんが試してくださったように、１５個くらいあれば十分だとは思いますが・・・
○VBAを開くのがはじめてだったので、すったもんだやってる間にモジュールが３つもできてしまいました。成功した最後のモジュールを残して、あとは削除したいのですが、これはモジュールの解放、という項目がそれにあたるのでしょうか？そんなの本で勉強しなさい、という次元ですが、とりあえずできたプログラムはまずきちんとしたかたちでとっておきたいので・・・もし良かったら教えてください。何度もごめんなさい。

回答No.4

moon_piyo

以前別の方への質問に回答したものです
試してみたら20個の数値の場合で5秒前後で一致する解をすべて洗い出します。
ただし負数を含む解はみつけることができない場合があります

参考URL：

http://pc.okweb.jp/kotaeru.php3?q=1229646

お礼

ご回答ありがとうございます。
過去の質問拝見させていただきました。
VBAモジュールに、最後に組んでおられたプログラムを貼り付けて実行してみたのですが、砂時計が動かず・・・
きっと質問者の方のやりとりを見つつチェックしていかないからそうなってしまったのかもしれません。
時間があるときにもう一度じっくり順を追って試したいと思います。
ここで質問する前に、一応同じような質問がないか検索したのですが、カテゴリーやキーワードがまずかったのかヒットしなかったのです。やはりこういった質問は過去にもあったのですね。ご親切にありがとうございました！！

回答No.3

matsu_jun

作りました。
A列に候補をA1から順に隙間無く入力してください。セルB1に目標値を入力してください。
その上で以下を実行すると、ぴったりとなる場合はその組合せを、ぴったりとならない場合は、絶対値で最も近い組合せをC列以右に記載します。C1セルには目標値との差を、C3セルから下へその要素となる数、D4列から下へ、C列に記載された数が何行目にあるかを記載します。組合せが複数ある場合はE,F列、G,h列、I,J列・・・と右へ書き込んでいきます。
総当りで確認していますので、15～16個の数字までが実用的な処理速度とおもいます。15個で試してみたところ、20秒くらい処理にかかっています。

ルーチンとしては、(候補の数)桁の2進数を0からインクリメントしてゆき、全てのnについて、n桁の数字とn行目の数字の積を求め、その総和を確認しています。

'ここから-------------------------------------------------------------
Sub 袋詰問題()
Application.ScreenUpdating = False '処理中の画面の書き換えを禁止
On Error GoTo ERREND

Dim InpDataCnt As Long '入力データ数
Dim InpDataArr() As Boolean '入力データ桁毎加算フラグ配列
Dim CalEndFlag As Boolean '計算終了フラグ
Dim CntUpFlag As Boolean 'フラグ桁上がりフラグ
Dim TargetVal As Double '目標値
Dim ResultVal As Double '計算値
Dim ResultRange As Double '目標値との差
Dim ResWrtCol As Integer '計算結果書き込み列
Dim ResWrtRaw As Long '計算結果書き込み行
Dim BoolTmp As Boolean

'シートデータの取り込みと初期設定-------------------
InpDataCnt = Cells(65536, 1).End(xlUp).Row '要素数の取得
ReDim InpDataArr(InpDataCnt)
CalEndFlag = True
TargetVal = CDbl(Cells(1, 2).Value)
ResultVal = 0
ResultRange = Abs(TargetVal - ResultVal)
ResWrtCol = 3
'---------------------------------------------------

Do While 1
'入力データ桁毎加算フラグ配列記入-------------------
'('要素数'桁の2進数を000・・・0から111・・・1まで全て確認)
CntUpFlag = False
InpDataArr(1) = InpDataArr(1) Xor True
If InpDataArr(1) = True Then
ResultVal = CDbl(Cells(1, 1).Value)
Else
CntUpFlag = True
End If
CalEndFlag = InpDataArr(1)
For i& = 2 To InpDataCnt
BoolTmp = InpDataArr(i) And CntUpFlag
InpDataArr(i) = InpDataArr(i) Xor CntUpFlag
CntUpFlag = BoolTmp
If InpDataArr(i) = True Then ResultVal = ResultVal + CDbl(Cells(i, 1).Value)
CalEndFlag = CalEndFlag Or InpDataArr(i)
Next i
'---------------------------------------------------

'全ての可能性をチェックしたら終了-------------------
If CalEndFlag = False Then Exit Do
'---------------------------------------------------

'暫定の最低値との比較-------------------------------
If ResultRange >= Abs(TargetVal - ResultVal) Then '最低値を更新できなければ何もしない
'最低値更新の場合の処理---------------------
If ResultRange > Abs(TargetVal - ResultVal) Then
ResWrtCol = 3
Range(Cells(1, 3), Cells(65536, 256)).Delete '今までの暫定結果を消去
Cells(1, 3).Value = "目標値との差" '目標値との差を記載
Cells(1, 4).Value = Abs(TargetVal - ResultVal)
'最低値同率1位の場合の処理------------------
Else
ResWrtCol = ResWrtCol + 2 '結果書き込み列を2列右にオフセット
If ResWrtCol > 256 Then '256列を超えてしまうと書き込めないので終了
MsgBox ("候補が多すぎるので終了します")
GoTo ERREND
End If
End If
'最低値更新または同率1位の場合の処理--------
ResultRange = Abs(TargetVal - ResultVal)
ResWrtRaw = 3
For j# = 1 To InpDataCnt
If InpDataArr(j) = True Then '構成要素と、その要素のある行数を記載
Cells(ResWrtRaw, ResWrtCol).Value = Cells(j, 1).Value
Cells(ResWrtRaw, ResWrtCol + 1).Value = CStr(j) & "行目"
ResWrtRaw = ResWrtRaw + 1
End If
Next j
End If
'---------------------------------------------------

ResultVal = 0

Loop

ERREND:
Application.ScreenUpdating = True
End Sub
'ここまで-------------------------------------------------------------

上の貼り付け方が分からない場合は、以下ご覧下さい。
1) ツール(T)－マクロ(M)－新しいマクロの記録(R)を開く
2) 「マクロの記録」ウィンドウのマクロ名(M)の欄に、「袋詰問題」と記載し、OKをクリック
3) 画面上に二つのボタンが表示されたツールバーが現れたら、左側の「■」をクリックして記録終了
4) Altキーを押しながらF8キーを押して、マクロウィンドウを開く
5) マクロ名(M)から「袋詰問題」を選び、編集(E)ボタンをクリック
6) 現れた「Microsoft Visual Basic」の右側に
Sub 袋詰問題()
'
'
'
End Sub
と書いてある部分に上を貼り付ける

補足

今早速やってみています。教えていただいたとおりにプログラムをコピーして貼り付けし、ツールバーから実行を押してみるのですが、エラーが出ます。
内容は「コンパイル　エラー　名前が適切ではありません：袋詰問題」と出てしまいます。もしかしてプログラムをはりつける前に出る
Sub 袋詰問題()
'
'
'
End Sub　←ここの部分と、私がコピーして張り付ける部分にダブりがあるのでしょうか？
VBAを開いた時点でカーソルは１つめのカンマのところに出ます。そこに、ここから------ここまで------の部分をまるまる貼り付けています。これではいけないのでしょうか？
コピペが間違いなのか、はたまた実行のやり方がまずいのかわからないのです。
何しろマクロを使うのも実行するのも初めてで・・使えもしないくせに作ってもらってしまって本当にすみません。

回答No.2

neKo_deux

この問題は「ナップザック問題」と呼ばれる最適化問題、線形計画法の問題そのものですね。
プログラムするのでしたら、ほとんどそのまま使えるサンプルがあります。

ナップザック問題をExcelで解く
http://www.geocities.co.jp/SiliconValley-Oakland/8139/

--
具体的な手順ですと、

1) データ入力
適当に新規作成したBookに、
A1 999,000
A2 735,000
…
A13 221,812
を入力。

2) VBA作成
Alt+F11でVBEditor起動。
[挿入]-[標準モジュール]でModule1作成。
参考URLの「３．動的計画法」の
「動的計画法により目標値に最も近い物をひとつだけ求める」を貼り付け。

3) VBA修正
Const N = 35 ' データの数
Const wmax = 100000 ' 目標値
↓
Const N = 13 ' データの数
Const wmax = 2476620 ' 目標値
と修正。

4) 編集終了
VBEditorを閉じる。

5) 実行
Excelの、
[ツール]-[マクロ]
「マクロ」ダイアログから、
knap_mainを選択
実行。

それなりに時間がかかって…celeronで数分間？
（VBAの中断は[Ctrl]+[pause/Break]です。）

6) 結果表示
735000
429996
299470
407862
0
251492
0
0
352800
が出ました。

--
解の探索方としては遺伝的アルゴリズムなんかを使うと、上のプログラムほどはメモリを使わないハズですが…。

参考URL：

http://www.geocities.co.jp/SiliconValley-Oakland/8139/

補足

でました！思ったより時間もかかりませんでした。
その都度データの数と目標値にあわせて、変更すべき点を変更して実行すればよいということですよね？
一応確認させていただきたいのですが、VBAを呼び出して、モジュール上でデータを変更し、上書き保存ボタンを押したうえで閉じ、実行する、という形をとったほうがいいのでしょうか？
とりあえずうまくいったので、このデータはそっと温存しておきたいのですが、VBA画面は初めて開いたので、いろんなアイコンをさわったりするとたちまちおかしくなってしまいそうなので・・・
くだらないようですがアドバイスお願いします。

回答No.1

thisis2wakei

最大15個だとすれば、
14個目と15個目を0として、常に15個とします。
組み合わせは32768通りで、
各数字がＯＮの場合、ＯＦＦの場合で2の15乗ですよね。
なので、1行から32768行に十進数で1～32768を記述して、
その隣に、1桁分ずつ割りながら、Ｂ～Ｐ列まで利用して、一桁ずつ1かゼロを計算して行きます。（二進数に変換）
その桁数に応じて、Ｑ列に、1のときは1倍、0のときは、0倍と言うような合計の計算をして行きながら、
Ｒ列には、もし、その合計が、2476620だったら、1、違ったら、0、と言うようなＩＦ関数を記述します。
あとは、Ｒ列が1のものを拾うだけで、完成！
これなら新しい知識は要らないはずですよ。

お礼

ご回答ありがとうございます。数学的見地を利用して、順序だててやっていけばできるということの証明ですよね。昔から数学が苦手で、考え方をスムーズに理解できなくて・・・
二進数に変換するところですでにこんがらがってます・・・桁とは、１～１５桁で割って、一の位が１か０になるかを計算するということでしょうか（汗）
時間のあるときにやってみながらどういうしくみになるのか、試してみたいと思います。
親切に教えていただいてたのに、ぱっと理解できなくてすみません（-＿-；）

補足

ありがとうございます。明日早速試してみたいと思います。結果はまたご報告しますね。