[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『最適な箱数を求めたい』(ひな)
関数またはマクロで、以下の条件で最適な箱数を
求めたいと思います。どなたかご教授頂けますでしょうか。
1ロット300m巻のロープがあり、そこからランダムな長さを 切り出していった場合、何箱必要かを求めたいです。
例えば、 A B C D E F 150 100 80 180 140 50 30 250 120 50 100 90
と、表に値があります。1本のロープは途中で切ったりせず、 効率の良い組み合わせで切っていった場合に、何箱必要と なるのかを算出したいです。
A列とかB列などのグループは全く気にする必要はありません。 上記の場合、全ての値を加算した長さは1340mとなりますが、 300m巻の1本のロープからA1の150+B1の100を切り出した 残りが50mなので、D2の50mを切り出すと丁度1箱となります。
このように計算していくと、上記すべてを切り出すには 1340÷300=4.46で5箱が必要とはなりますが、余ったロープの 長さによっては5箱とは限らなくなります。 実際には上記のような切りの良い長さではないからです。
解りづらい説明で申し訳ありませんが、何か良い計算式は 無いでしょうか。 よろしくお願い致します。
< 使用 Excel:Excel2007、使用 OS:Windows7 >
0.カットする長さを降順に並べる
1.最長のものに、次に長いものを加えて300以下になるかどうかを判定する
2.300以下だったら次に長いものを加えて300以下になるかを判定する
3.1〜2を繰り返し、300を超えたら、直前までの加算値とその組み合わせで1箱とする
4.3の結果残ったもので、1〜3を繰り返す
たぶんこの方法をVBAで実現させるといいような気がします。
ちなみに質問者のサンプルで上記アプローチで計算すると5箱と求められますが、これが最適解
なのかどうかはわかりません。
(ryopo^2) 2014/09/12(金) 10:39
これ参考になりますかね? 最適は難しい問題だと思います(私には無理) (稲葉) 2014/09/12(金) 10:42
質問とは全く関係ないですが。
「箱数」でピクッとなってしまったので関係ないですがリンクします。
http://ja.wikipedia.org/wiki/Wikipedia:%E4%BA%95%E6%88%B8%E7%AB%AF/subj/%E3%80%8C%E9%96%A2%E6%95%B0%E3%80%8D%E3%81%8B%E3%80%8C%E5%87%BD%E6%95%B0%E3%80%8D%E3%81%8B
(カリーニン) 2014/09/12(金) 10:48
ryopo^2さん、稲葉さん、カリーニンさん(?)、 お返事ありがとうございます!
ryopo^2さんの方法でVBAを作れれば、最適な気がします。 また、稲葉さんが貼ってくださったリンクの「ソルバー」は、 使えるのでしょうか?2007ですと何処になるのかわかりません・・。
(ひな) 2014/09/12(金) 10:59
ソルバーをインストールしてみたのですが、 私には扱えそうもありません・・。
勝手を申しますが、どなたかryopo^2さんの方法でVBAを 作って頂けないでしょうか?
(ひな) 2014/09/12(金) 11:18
簡単なパターンを考えてみます。
100m巻から、90,80,70,30,20,10 の長さを切り出すとします。 単純に上から順に組み合わせていくと 90,80,70,30,20,10 ● ◇ ▲ ▲ ○ ○ ・・・・4巻必要で、あまりが70m 最適は 90,10 80,20 70,30 と組み合わせて、 ● ● ▲ ▲ ○ ○ ・・・・3巻必要で、あまりが 0m
ソルバーを扱えるようになるのが良いと思います。 (HANA) 2014/09/12(金) 11:37
HANAさん、ありがとうございます!
ソルバーで出来そうな気がします。 目的セル、目標値、変化させるセル、制約条件と、 指定する内容が分かりかねています。
もう少し頑張ってみます。
(ひな) 2014/09/12(金) 11:42
Private Sub test() Const NUMMAX = 300 Dim i As Long Dim j As Long Dim iMax As Long Dim iNum As Long Dim iAll As Long Dim iTest As Long Dim iDim() As Long
iNum = 1 iMax = Cells(Rows.Count, "A").End(xlUp).Row ReDim iDim(iMax - 1, 1) For i = 1 To iMax iDim(i - 1, 0) = Cells(i, "A").Value Next i
Columns(2).ClearContents
For i = 0 To iMax - 1 If iDim(i, 1) = 0 Then iAll = iDim(i, 0) iDim(i, 1) = iNum For j = i + 1 To iMax - 1 If iDim(j, 1) = 0 Then iTest = iAll + iDim(j, 0) If iTest <= NUMMAX Then iDim(j, 1) = iNum iAll = iTest End If End If Next j iNum = iNum + 1 End If Next i
For i = 1 To iMax Cells(i, "B").Value = iDim(i - 1, 1) Next i
MsgBox iNum - 1 & "箱必要です", vbInformation, "計算終了" End Sub (???) 2014/09/12(金) 12:35
「???」さん、思考をVBA化してくださってありがとうございます。
(ryopo^2) 2014/09/12(金) 12:59
皆様、本当にありがとうございます!!
???さんに作って頂いたVBAで必要数が算出できました。 ありがとうございます。
先ほどvarumさんが少しの間UPしてくださったレスのように、 最後に書かれていた最適解のように 切残しが把握できれば・・・と思っているところです。
もう少し考えてみます! (ひな) 2014/09/12(金) 13:33
ひなさんと更新のタイミングが一致したようで 無効になったため再度upします。
次の記事が参考になると思います。
材料の切断について http://www.excel.studio-kazu.jp/kw/20120410160047.html
この中で提示されているコードがおそらく役立つでしょう。 少し難しいケースですと最適解が得られないこともありますが 自分でロジックを考えて作るよりもはるかに楽なのは確か。 必要ならもっと改善すればよろしいかと。
もう1つ紹介しておきます。英語のブログですが、コードは関係なく 利用できます。
Cutting Stock Lengths http://dailydoseofexcel.com/archives/2005/09/12/cutting-stock-lengths/
結果がメッセージボックスに表示されるので、その部分のコードを 修正した方が使い易いかも。
最後に提示されたサンプルの解について
[ 250 , 50 ] 切残し 0 [ 180, 120 ] 切残し 0 [ 150, 100, 50 ] 切残し 0 [ 100, 90, 80, 30 ] 切残し 0 [ 140 ] 切残し 160
以上の5箱が最適解です。
それから箱数だけではあまり役に立たないです。 切り方によって箱数が変わるから、カッティング・パターンは必須です。
(varum) 2014/09/12(金) 13:53
varumさんスミマセン、お手数掛けます。
仰るように、カッティング・パターンを把握できればと 思っていたところでした。
参考にさせて頂きます。 誠にありがとうございました!
(ひな) 2014/09/12(金) 14:15
後で思い出しました。 切断長さの種類が10までならば下記のようなものがあります。
On-Demand Cutting Optimization Solution http://www.cutsolution.com/CutSolution/jsp/freeTrial.jsp
Web上で計算して結果を知らせてくれます。 ただし、変なソフトの広告画面が現れるときがあるので要注意。
上部のメニューバーの左から4つ目の"Free Trial"をマウスで クリックすると、データの入力画面に切り替わる。 特に、変なソフトの広告が出る前にこの操作をするのがよい。
Available Stock Length 材料長さを入力 Length of demand 切断長さを入力 No of ....(Frequency) 必要数
1つの値を入力した後、Tab キーを押すと次の項目の枠に移動する ので便利です。 全てのデータを入力後に、[Cutting Plan]のボタンをクリックすると すぐに結果をテキストファイルで返信してくれる。
因みに、以下は提示されたサンプルを計算した結果をコピーしたもの。 結果は悪くありません。
言うまでもないけど、ご自身の責任で使ってください。
=================== Length of available stock ============= 300 =================== Original Length of rolls ============== 250 180 150 140 120 100 90 80 50 30 =================== Original Demand of rolls ============== 1 1 1 1 1 2 1 1 2 1 =================== Merged Length of rolls ================ 250 180 150 140 120 100 90 80 50 30 =================== Merged Demand of rolls ================ 1 1 1 1 1 2 1 1 2 1 =================== Cutting Patterns ====================== <Rolls> <Wastage in one> <TotalWastage> Cutting Pattern (Length)Count Length(Count).. 1 0 0 (250)1 (50)1 1 0 0 (180)1 (120)1 1 10 10 (150)1 (140)1 1 10 10 (100)2 (90)1 1 140 140 (80)1 (50)1 (30)1 =================== Analysis of wastage =================== Total Roll Required 5 % Trim 10.6667
(varum) 2014/09/12(金) 16:19
varumさん、ご親切にありがとうございます。
ソフト活用も検討してみます。
(ひな) 2014/09/12(金) 16:44
以前、 [[20120308214011]] ここで作成したものをちょっと変更したものです。
新規ブックにて(Sheet1とSheet2というシートが存在する)、
標準モジュール(Module1)に サンプルデータ作成コード
'=================================================================================== Option Explicit Sub レイアウト() With Worksheets("sheet1") .Range("a:h").ColumnWidth = 14 .Range("e2:h2").Value = Array("一巻のM数", 300, "確認インターバル", #12:05:00 AM#) .Range("a1:b12").Value = Evaluate("{1,150;2,100;3,80;4,180;5,140;6,50;7,30;8,250;9,120;10,50;11,100;12,90}") End With end Sub
標準モジュール(Module2)に組合せリスト作成プログラム
'========================================================================= Option Explicit Private c_svsn As Long '抜き取り数保存 Private c_svsmpn As Long '標本数保存 Private c_idx() As Long '配列のカレントポインタ Private cs_x() As Long '配列の基盤ポインタ Private c_eof As Boolean '========================================================================= Function init_comb(smpnum As Long, seln As Long) As Double '組合せ処理ルーチンの初期化 'Input : smpnum 標本数 seln 抜き取り数 'output : init_comb 組合せ数 Dim g0 As Long c_svsn = seln c_svsmpn = smpnum Erase c_idx() Erase cs_x() g0 = 1 ReDim cs_x(1 To seln) ReDim c_idx(1 To seln) For g0 = 1 To UBound(c_idx()) cs_x(g0) = g0 c_idx(g0) = g0 Next c_idx(UBound(c_idx())) = c_idx(UBound(c_idx())) - 1 init_comb = WorksheetFunction.Combin(smpnum, seln) c_eof = False End Function '========================================================================= Function get_comb(ans()) As Long '組合せリストのインデックスを配列として返す 'input : なし 'output: ans() 組合せリストのインデックスを格納する ' get_comb 0:正常に取得 1 リストの終わり Dim g0 As Long Dim g1 As Long get_comb = 1 If c_eof Then Exit Function For g0 = UBound(c_idx()) To LBound(c_idx()) Step -1 If c_idx(g0) + 1 <= c_svsmpn - c_svsn + g0 Then c_idx(g0) = c_idx(g0) + 1 get_comb = 0 Exit For Else c_idx(g0) = cs_x(g0) + 1 cs_x(g0) = cs_x(g0) + 1 For g1 = g0 + 1 To UBound(cs_x()) cs_x(g1) = cs_x(g1 - 1) + 1 c_idx(g1) = cs_x(g1) Next g1 End If Next If get_comb = 0 Then For g0 = LBound(c_idx()) To UBound(c_idx()) ans(g0) = c_idx(g0) Next Else c_eof = True End If End Function '========================================================================= Sub close_comb() '組合せ処理ルーチンの終了処理 Erase c_idx() Erase cs_x() End Sub '========================================================================= Function skip_comb(i_num As Long, ans() As Variant) As Long '指定したインデックスを一つ増加させる 'input: i_num:増加させるインデックス 'output: ans()組合せリストのインデックスを格納する ' skip_comb 0:正常に取得 1 リストの終わり Dim g0 As Long Dim g1 As Long skip_comb = 1 g1 = c_svsmpn If c_eof Then Exit Function For g0 = UBound(c_idx()) To i_num + 1 Step -1 c_idx(g0) = g1 g1 = g1 - 1 Next skip_comb = get_comb(ans()) End Function Function set_comb(setarray(), ans()) As Long 'setarray()で指定された組合せインデックスをカレント設定する 'input setarray() カレントに設定するインデックスの配列 'Output ans() 組合せリストのインデックスを格納する 'set_comb 0:正常に取得 1 既に指定インデックス、または越えています Dim g0 As Long Dim ret As Long Dim sidx As Long Dim skipsw As Long '0 skip_combを最低一回は、呼び出している 1 skip_combを一回も呼び出していない Dim neqsw As Long '0 設定インデックスがインデックス限界値内にある 1 設定インデックスがインデックス限界値を越えた ReDim sv(1 To c_svsn) set_comb = 1 skipsw = 1 neqsw = 0 For g0 = LBound(setarray()) To UBound(setarray()) If c_idx(g0) > setarray(g0) Then Exit For Else sidx = setarray(g0) If sidx > c_svsmpn - c_svsn + g0 Then neqsw = 1 sidx = c_svsmpn - c_svsn + g0 End If Do Until c_idx(g0) = sidx ret = skip_comb(sidx, sv()) skipsw = 0 Loop If neqsw = 1 Then Exit For End If Next If skipsw = 0 Then For g0 = LBound(sv()) To UBound(sv()) ans(g0) = sv(g0) Next set_comb = 0 End If Erase sv() End Function
標準モジュール(Module3)に今回の仕様遂行コード '====================================================================== Sub main() Dim 組合せ As Variant Dim rw As Long Dim rng As Range Dim g0 As Long [e5:h100000].Clear rw = 5 Set rng = Range("a1", Cells(Rows.count, "a").End(xlUp)).Resize(, 2) rng.Interior.ColorIndex = xlNone rng.Sort Key1:=Range("b1"), Order1:=xlDescending, Header:=xlNo Do While get_合計組合せ(rng, Range("f2").Value, Range("h2").Value, 組合せ, Worksheets("sheet2")) For g0 = LBound(組合せ) To UBound(組合せ) Cells(rw, g0 + 4).Value = 組合せ(g0) Next rw = rw + 1 DoEvents Loop Set rng = Range("a1", Cells(Rows.count, "a").End(xlUp)).Resize(, 2) rng.Sort Key1:=Range("a1"), Order1:=xlAscending, Header:=xlNo With Range("a:c") .Interior.ColorIndex = xlNone .Columns(3).Clear End With Worksheets("sheet2").Range("a:b").Clear End Sub '================================================================================ Function get_合計組合せ(ByVal rng As Range, ByVal 解 As Long, ByVal inttm As Variant, 組合せ As Variant, ByVal wksht As Worksheet) As Boolean Dim 有効値 As Long Dim Tdata() As Variant Dim trw() As Variant Dim snum As Long Dim nuki As Long Dim g0 As Long Dim g1 As Long Dim g2 As Long Dim ret As Long Dim asum As Long Dim tm As Double Dim Mret As Long Dim bestsum As Long Dim setsw As Long Dim sv() As Variant Dim ans() Dim cmb() As Variant Dim crng As Range get_合計組合せ = False Mret = vbOK rng.Copy wksht.Range("a1") g0 = 0 For Each crng In rng.Offset(0, 1).Resize(, 1) With crng If .Interior.ColorIndex = xlNone Then ReDim Preserve Tdata(1 To g0 + 1) ReDim Preserve trw(1 To g0 + 1) Tdata(g0 + 1) = .Value trw(g0 + 1) = .Row g0 = g0 + 1 End If End With Next If g0 <= 0 Then Exit Function snum = UBound(Tdata) asum = 0 For g0 = UBound(Tdata) To LBound(Tdata) Step -1 asum = asum + Tdata(g0) If asum > 解 Then snum = UBound(Tdata) - g0 Exit For End If Next bestsum = 解 有効値 = 0 tm = [now()] For g0 = 1 To snum Call init_comb(UBound(Tdata), g0) ReDim ans(1 To g0) ReDim cmb(1 To g0) ret = 1 If setsw = 1 Then ret = set_comb(sv(), ans()) End If ReDim sv(1 To g0) setsw = 0 If ret <> 0 Then ret = get_comb(ans()) Do While ret = 0 asum = 0 For g1 = LBound(ans()) To UBound(ans()) asum = asum + Tdata(ans(g1)) cmb(g1) = Tdata(ans(g1)) If asum > 解 Then Exit For Next nuki = g1 If asum <= 解 And setsw = 0 Then For g1 = LBound(ans()) To UBound(ans()) sv(g1) = ans(g1) Next setsw = 1 End If If nuki >= UBound(ans()) Then If asum < 有効値 Then nuki = chk_seq(ans()) If nuki > 0 Then ret = skip_comb(nuki, ans()) Else Exit Do End If Else If asum >= 有効値 And asum <= 解 Then wksht.Range(rng.Address).Copy rng.Cells(1, 1) For g1 = LBound(ans()) To UBound(ans()) rng.Cells(trw(ans(g1)), 1).Resize(, 2).Interior.ColorIndex = 4 Next get_合計組合せ = True 組合せ = cmb() Cells(g2 + 1, 3).Value = UBound(ans()) & "件 合計 : " & asum g2 = g2 + 1 有効値 = asum tm = [now()] End If If asum = 解 Then Mret = vbCancel Exit Do End If ret = get_comb(ans()) End If Else ret = skip_comb(nuki, ans()) End If If [now()] - tm > inttm Then Mret = MsgBox("抜き出し " & g0 & "件 実行中 続けますか?", vbOKCancel) tm = [now()] If Mret = vbCancel Then get_合計組合せ = False: Exit Do End If Loop Call close_comb If Mret = vbCancel Then Exit For Next Erase ans() Erase Tdata Erase trw() Erase cmb() End Function '========================================== Function chk_seq(ans()) As Long chk_seq = 0 Dim g0 As Long For g0 = UBound(ans()) To LBound(ans()) + 1 Step -1 If ans(g0) <> ans(g0 - 1) + 1 Then chk_seq = g0 - 1 Exit For End If Next End Function
以上です。sheet2は、手抜きロジックなので、プログラムが使っていますから、 用意だけしておいてください。
まず、Sheet1をアクティブにした状態で レイアウト というプロシジャーを 実行してください。
Sheet1のA列がA1から連番、B列にB1からB2,B3と切り出しメートルデータ、
セルF2に1巻のメートル数、H2にプログラムが長い場合、動作中断確認をする時間を示します。
A列、B列のデータは、適当に変更して見てください。
mainを実行してみてください。
E5から、組み合わせが表示されます。
サンプルデータだと
250 50 180 120 150 100 50 100 90 80 30 140
こんな結果が得られました。
(ichinose) 2014/09/12(金) 20:26
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.