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

Question

先週、数学カテゴリで質問させていただいたのですが、解を導きだすのに手計算では無理があるので、コンピュータにまかせたほうがいいというアドバイスをいただきました。

たとえば、ここに１３個の数値があります。

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になる数値を選びだしたいと思っています。
（毎月、各数値と候補となる数値の個数（例では１３個）、和の合計は変化します。）
業務上必要となるのですが、こういった流れをくむ問題の解を、瞬時に計算してくれる式は、エクセル等で組めるのでしょうか？関数というより、プログラミングレベルなのかもしれませんが、プログラムについて全然詳しくないので、言語と使用環境の関係がよくわかりません。ですのでエクセルを使用して作業することができればと思っています。
候補となる数値の個数は最大でも１５個くらいかと思います。
わざわざお金を出してプログラムを作成するまで規模も使用頻度もなく、かといって手計算では組み合わせの確率的にいって無理があるので、何とかオフィスソフト使用により自分で処理したいところです。知識のあるかたのご教授をお願いできたらと思っています。よろしくお願いいたします。

matsu_jun · Accepted Answer

#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○をエクスポートしますか?」と聞かれると思いますが、「いいえ」を選んでもらって結構です。どうせ検証途中の不要なモジュールですから、潔く捨てちゃいましょう。

thisis2wakei · Answer

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が組めるようになっても、こういう基本的なまわし方を常に考えるようにすると、応用の利くプログラムが書けるようになりますよ。
ちょっと偉そうか（笑）

matsu_jun · Answer

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

moon_piyo · Answer

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

参考URL：http://pc.okweb.jp/kotaeru.php3?q=1229646

matsu_jun · Answer

作りました。
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
と書いてある部分に上を貼り付ける

neKo_deux · Answer

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

thisis2wakei · Answer

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

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

#3、#5のmatsu_junです。

No.1の補足です。

#3のmatsu_junです。

この回答への補足

以前別の方への質問に回答したものです

作りました。

この回答への補足

この問題は「ナップザック問題」と呼ばれる最適化問題、線形計画法の問題そのものですね。

この回答への補足

最大15個だとすれば、

この回答への補足

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング