[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『最適な箱数を求めたい』（ひな）
関数またはマクロで、以下の条件で最適な箱数を
求めたいと思います。どなたかご教授頂けますでしょうか。
１ロット300ｍ巻のロープがあり、そこからランダムな長さを 切り出していった場合、何箱必要かを求めたいです。
例えば、 A B C D E F 150 100 80 180 140 50 30 250 120 50 100 90
と、表に値があります。1本のロープは途中で切ったりせず、 効率の良い組み合わせで切っていった場合に、何箱必要と なるのかを算出したいです。
A列とかB列などのグループは全く気にする必要はありません。 上記の場合、全ての値を加算した長さは1340ｍとなりますが、 300ｍ巻の1本のロープからA1の150＋B1の100を切り出した 残りが50ｍなので、D2の50ｍを切り出すと丁度1箱となります。
このように計算していくと、上記すべてを切り出すには 1340÷300＝4.46で5箱が必要とはなりますが、余ったロープの 長さによっては5箱とは限らなくなります。 実際には上記のような切りの良い長さではないからです。
解りづらい説明で申し訳ありませんが、何か良い計算式は 無いでしょうか。 よろしくお願い致します。
＜ 使用 Excel：Excel2007、使用 OS：Windows7 ＞
０．カットする長さを降順に並べる
１．最長のものに、次に長いものを加えて300以下になるかどうかを判定する
２．300以下だったら次に長いものを加えて300以下になるかを判定する
３．１〜２を繰り返し、３００を超えたら、直前までの加算値とその組み合わせで１箱とする
４．３の結果残ったもので、1〜３を繰り返す
たぶんこの方法をＶＢＡで実現させるといいような気がします。
ちなみに質問者のサンプルで上記アプローチで計算すると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
「？？？」さん、思考をＶＢＡ化してくださってありがとうございます。
（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
この中で提示されているコードがおそらく役立つでしょう。 少し難しいケースですと最適解が得られないこともありますが 自分でロジックを考えて作るよりもはるかに楽なのは確か。 必要ならもっと改善すればよろしいかと。
もう１つ紹介しておきます。英語のブログですが、コードは関係なく 利用できます。
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上で計算して結果を知らせてくれます。 ただし、変なソフトの広告画面が現れるときがあるので要注意。
上部のメニューバーの左から４つ目の"Free Trial"をマウスで クリックすると、データの入力画面に切り替わる。 特に、変なソフトの広告が出る前にこの操作をするのがよい。
Available Stock Length 材料長さを入力 Length of demand 切断長さを入力 No of ....(Frequency) 必要数
１つの値を入力した後、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のＡ列がA1から連番、Ｂ列にB1からB2,B3と切り出しメートルデータ、
セルF2に1巻のメートル数、H2にプログラムが長い場合、動作中断確認をする時間を示します。
Ａ列、Ｂ列のデータは、適当に変更して見てください。
mainを実行してみてください。
Ｅ５から、組み合わせが表示されます。
サンプルデータだと
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.