[[20160329175750]] 『VBAで最適な組み合わせ』(mana) >>BOT

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『VBAで最適な組み合わせ』(mana)

非常に説明しづらいのですが、手詰まりしております。
どなたか考え方やロジックの組み方をお願い致します。

やりたい事
在庫シートにある各製品の在庫と長さを見て、
最適計算シートのD列とE列に在庫シートの長さと本数を一番無駄がないように入れたい。

在庫シートはseihin昇順、nagasa昇順
最適計算シートseihin昇順、nagasa降順で並んでおります。

在庫シートのzaikoがある分しか割り当てられず、
nagasaの長いものから使用していく。
割り当てたnagasaの端数で出たら、別seihinになるべく使用できるようにする。

在庫シート

          A      B     C
  1行目 seihin zaiko nagasa
  2行目   A      10   1900
  3行目   A       1   2000
  4行目   A       1   2500
  5行目   A      30   3000
  6行目   B     100    500
  7行目   B     200   1000
  8行目   B      10   2000
  9行目   B      20   3000

最適計算シート

          A      B     C     D            E
  1行目 seihin kazu  nagasa  SIYOnagasa1  SIYOkazu
  2行目   A       2    791    3000           1
  3行目   A       2    574    2500           1
  4行目   A       3    342
  5行目   A       4    327
  5行目   A       1    200
  6行目   B       2   2180    3000           2
  7行目   B       1   1480    2000           1
   ・
   ・
   ・

 最適計算シート1行目
  3000×1の内訳 791×2、574×2、200×1の計2930分
 最適計算シート2行目
  2000×1の内訳 342×3、327×4の計2334分
 最適計算シート6行目
  3000×2の内訳 2180を1つづつ
 最適計算シート7行目
  2000×1の内訳 1480を1つ

< 使用 Excel:Excel2010、使用 OS:Windows7 >


何となく、延べ板を必要な長さずつ切断していくラインを想像しました。どういう用途に使うのかの具体的説明があれば、考えやすくなります。

こういう、組合せが多数存在するものから最適解を得るロジックというのは、とても難しいのです。
計算が単純であれば、Excelのゴールシーク機能が使えるのですが、ご指定の内容では複雑すぎるので駄目でしょう。
お金を出して、プロを雇って作成してもらうくらいの難易度かと思いますよ。

また、ロジックを考えるにも、挙げて頂いた例の判断基準がよく判りません。
例えば、最適計算シートの2行目は、791*2 となり、使用する在庫は 3000*1 だという事ですよね?
しかし、791*2 ならば 1900 の在庫を使ったほうが余りが少ないかと思います。何故3000の方が使用されるのでしょう?
長いから? 長い方で良ければ、全て在庫の一番下から選ぶだけですが、でも余りが少ないほうが資源が無駄にならないですよね?
それに、3行目は2500の方を使用しているので、一番長いものを採用、という基準でも無さそうです。

あと、余った分を再利用という考え方はアリですが、自動的に余りを在庫に回すようなところまで処理せず、そこは手入力で十分かと思います。
(???) 2016/03/30(水) 11:35


'御参考
Dim uflg As Boolean
Sub main()
'あらかじめ作業用シート(wk)を作成しておく
'最適計算シートの2列(kazuとnagasa)の数字部分を範囲選択した状態(例えば"B2:C6"を選択)で実行
'nagasa合計の全パターンをwkに昇順で列挙
Dim i As Long, j As Long, k As Long, t As Long, m As Long
    Sheets("最適計算シート").Select
    Var = Selection
    Sheets("wk").Select
    Sheets("wk").Cells.ClearContents
    Sheets("wk").Range("A1").Resize(2, UBound(Var)) = Application.Transpose(Var)
    j = 1: t = 1
    Do While Val(Cells(1, j)) > 0
        Cells(11, j) = 0
        t = t * (Val(Cells(1, j)) + 1)
        j = j + 1
    Loop
    i = 12
    For i = 12 To 10 + t
    m = 0
    sr i, j - 1
    m = m + Val(Cells(i, j - 1)) * Val(Cells(2, j - 1))
        For k = j - 2 To 1 Step -1
            If uflg = True Then
            sr i, k
            Else
            Cells(i, k).Value = Cells(i - 1, k)
            End If
        m = m + Val(Cells(i, k)) * Val(Cells(2, k))
        Next k
    Cells(i, j) = m
    Next i
    With Sheets("wk").Sort
        .SortFields.Clear
        .SortFields.Add Key:=Sheets("wk").Range(Cells(12, j), Cells(i, j)), SortOn:=xlSortOnValues, Order:=xlAscending 
        .SetRange Sheets("wk").Range(Cells(12, 1), Cells(i, j))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Cells(10, j) = "nagasa昇順"
End Sub
Sub sr(arg1, arg2)
    If Cells(arg1 - 1, arg2) >= Cells(1, arg2) Then
    Cells(arg1, arg2).Value = 0
    uflg = True
    Else
    Cells(arg1, arg2).Value = Cells(arg1 - 1, arg2) + 1
    uflg = False
    End If
End Sub
(mm) 2016/03/30(水) 13:16

 回答ではないです。
 長さのデータ数はかなりあるようですが、皆さんが同じデータで検討
 しやすいように長さとその必要数を20セット位提示されたらどうですか。
 答えが分かっているものが理想ですがないでしょうね。

(cut) 2016/03/30(水) 18:48


Cutting Stock問題ないし複数ナップサック問題とか言う類の問題なんでしょうね。
変数の数にもよるでしょうから、ソルバーなんかでも難しいんでしょう。

既に指摘がありましたように、質問者さんには、
・もう少し現実的な意味合いの説明と、
・何を持って「最適」と言っているのか
・余りトリビアルでない具体例
をあらためて説明して欲しいね。

(γ) 2016/03/30(水) 22:48


皆様ご回答ありがとうございます。

具体的な意味合いを申しますと、(???)さんのおっしゃる通り
製品(延べ板の様な長尺品)を無駄なく(歩留りよく)カットするマスター長さと本数を算出したい。
になります。

//最適計算シートの2行目は、791*2 となり、使用する在庫は 3000*1 だという事ですよね?
//しかし、791*2 ならば 1900 の在庫を使ったほうが余りが少ないかと思います。

確かに791*2だけを見ると1900を1本が最適になりますが(残長さは318)、
791×2、574×2、200×1を3000を1本でカットした方が使用する本数が少なく歩留りもよくなります。(残長さ70)
1行づつ考えるのではなく、同一製品の本数と長さを加味し算出したいです。

また、最適計算シート6行目は2180×2、1480×1で合計長さ5840になります。
3000×2が一番本数が少なくなりますが、製品2180にマスター3000をあてがうと残が820になる為、残820は残りの2180×1、1480×1に使うことができません。
ですので、2180×2に3000×2を使う。1480×1に2000×1を使う。となり、計3本になります。

//何を持って「最適」と言っているのか

歩留りが一番いいものを選択し、使用する本数が少なくするのが最適の意味合いになります。

(mana) 2016/03/31(木) 15:44


なるほど、判断基準は理解しました。やはり、もの凄く難しいコーディングになりますね。
何が難しいかというと、組合せ数が膨大なので、ここから条件を満たすものをピックアップしていき、
一番無駄のないケースを採用する部分ですかね。

在庫数が10件しかない、とかなら、全ての組合せを算出し、条件に合っているものを挙げればよいので、簡単です。
2^10 = 1024通り。が、サンプルの在庫Aでも42枚。つまり2^42 = 4398046511104 通りになってしまい、Excelが扱える範囲を大きく超えます。
在庫Bだと、2^230…。天文学的組合せ数になりますが、人間ならあっというまに1つ特定できるという…。
なので、例えば製品Aならば在庫Aの3000のものは最大でも2枚、という事を計算で求める等、選択肢を減らす工夫が必要です。

まずは、1製品の並び(切断パターン)を、総当たりでシート表示するロジックを考えてください。
mmさんの例も、それを実現しようとしたものかと思います。
個数も分けて考えると、例えば製品Aでは12個の製品を並べる組合せ(12! = 479001600通り)になります。
全部表示は多すぎて不可能なので、同じ長さで並びが違うだけ、というパターンも、除外しましょう。
それでもおそらく多いので、実際には一番良いもの以外は読み捨てていくことになるでしょう。

次に、1パターンについて、必要な在庫の組合せも、同様に総当たりで試すロジックを考えてください。
在庫に関しては、製品合計を超える組合せは考えなくて良いので、個数上限を事前に計算し、組合せを減らしましょう。
ここまでコーディングできたならば、あとはは製品毎に繰り返すだけかと思います。

別案で、ランダムに素材と製品組合せを選び、判定し、OKならば記憶。これを繰り返し、OKであり前のものより個数が少ないものを
残していく、という手もあります。
(???) 2016/03/31(木) 18:07


追加説明ありがとうございます。
(791*1,342*2,327*4,200*1) 2983(余り 17)
(791*1,574*2,342*1) 2281(余り219)
なんているのもソルバーで出てきますね。
ただ、変数の小さいものならいいけど、大きいものは無理があります。

(???)さんの問題の評価がためになりますね。
実際のデータの大きさとか、示すと対応の難易度がさらに明確になると思われます。

"Cutting Stock問題"で、ネット検索してみました。
複数材料の同問題が↓こちらの記事で紹介されています。
引用されている海外文献が参考になるかもしれません。
http://mathinfo.blog.fc2.com/blog-entry-175.html
商用のソフトもあるようですね。

と、よく見たら、
まさにここの学校の質問が注目されているようですよ。皆さん頑張ってえ。
http://mathinfo.blog.fc2.com/blog-entry-178.html

(γ) 2016/03/31(木) 23:50


いやぁ、注目されても困ってしまいますねぇ。ちゃんと設計考えると、片手間にちょこっと、では済まなくなりますから。

コーディングを容易にする妥協案ですが、在庫は常に1枚で済ませる、というのは駄目でしょうか?
それならば、製品の順番なんてどんな順でも必ず加工可能な訳で、製品に必要な長さ合計が入りきる在庫を選ぶだけです。
製品A01、A02…というように、人間が在庫1つに対応可能な分で部品数を判断し、細分化する訳ですね。
そこを考えるのが面倒だから自動化したいのだ、と言われてしまえばおしまいなのですが。
(???) 2016/04/01(金) 11:22


Cutting Stockという文言を知りませんでしたが、
(γ)さん添付のURLがまさにイメージとおりです。

在庫シート/最適計算シートは300行近くあり、製品の種類も複数です。
また、在庫が0の場合や、在庫シート/最適計算シートは1レコードしかない場合もあります。

正直ダメならあきらめるか、どこか妥協しようと考えており、
VBAに精通したした人なら…と質問した次第です。

(???)さんの言う考え方をどうVBAでやるのか、
また(mm)さんがコーティングしてくれた結果をどう料理すれば算出できるのかが、
申し訳ありませんが私には想定できずにいます。

理想を言うのであれば、やはり在庫は常に1枚で済ませるというのは不可ですが、
VBAでは限界があるのでしたら、どこか妥協案を検討したいと思います。
(mana) 2016/04/01(金) 12:12


一般的な最適法は示されていないし、これを専門に研究している研究者がいるくらいの問題のようです。(いわゆるNP困難問題)

(参考)
「Cutting stock問題の難しさ」
http://mathinfo.blog.fc2.com/blog-entry-92.html

「組み合わせ最適化問題」
http://www.orsj.or.jp/~wiki/wiki/index.php/%E7%B5%84%E5%90%88%E3%81%9B%E6%9C%80%E9%81%A9%E5%8C%96%E5%95%8F%E9%A1%8C

商用ソフトのネタになるくらいの話なので、
"VBAに精通したひとであれば解けるだろう"といった程度の推測はありえません。
このことは、すでに???さんからご指摘のあったとおりです。

一つの製品でできればあとはその繰り返しなので、一つの製品に絞った場合、
・作成する製品の種類の数はどの程度か、(Aの例は5種類だが、現実はどの程度なのか)
・材料の種類の数(Aの例では4種類だが、現実には?)
・材料の個数上限は現実的なものなのかどうか(Aの例では、考慮する必要がないほど余裕があるが)
といったことが知らされれば、検討する範囲が狭まる可能性があると思います。
基本的に私には手に余るので、単に、言うだけの奴ですけど、
もしそれらが現実的な大きさのものならと思いまして。

また、(cut)さんが指摘されたように、現実に近い具体的な例を出されると
回答者さんも考えやすいのではないかと思いました。

(γ) 2016/04/02(土) 10:02


 門外漢なので、興味を持ってROMしてるだけのβです。

 その昔、コイルセンタでの板の裁断について、システム化を頼まれたことがあります。
 そのコイルセンタには、超熟練の神様のような職人さんがおられて、その人は、要求された部材の数とそれぞれのサイズを見て、
 在庫してある様々なサイズの金属板を眺め、頭の中でちゃちゃちゃっと線を引いて、よし、この板を使って
 部材を切りだそうと。

 いつも、見事なくらい、歩留まりがよかったんですが、老齢化で、その方の引退後に備えてシステム化しておこいと。
 その方の頭の中のロジックを教えてもらおうとしたんですが、いじわるではなく、勘とひらめきなのでということで
 結局スタッフの若い衆が、ああでもないこうでもないと。なんとか作り上げましたが、その方の歩留まり率には到底及ばなかったですね。

 でも、ないよりましだということで採用してもらいました。

 難しい世界なんですよね。

 脱線レス、失礼しました。

(β) 2016/04/02(土) 10:37


見当違いでしたら、申し訳ないのですが、

提示されているデータのパターンが少ないので、何ともいえませんが
nagasaの長いモノから使用するという条件があるので、あまり難しく
考えずに下記のような考え方で、組み合わせが抽出できないでしょうか?

ちなみに、最適計算シートの製品"A"を計算するとき、在庫シートの
製品"A"のみ対象とします。

#考え方
1.最適計算シートの対象製品("例えばA")の全長を取得(以降:製品全長)
2.在庫シートの対象製品("A")(以降:資材)から短いモノから順に製品全長より同じか長い資材を検索
・見つかった場合、その資材を(以降:対象資材)とする
・見つからなかった場合、在庫のある資材で最も長い資材を(以降:対象資材)とする
3.見つけた対象資材の全長から全対象製品に対して製品全長の長い順に長さと在庫を総当りで減算する
・この際、減算した対象資材の全長より長い対象製品は対象外とする
4.対象製品の在庫を減算した状態で?@〜?Bを対象製品の在庫が無くなるまで繰り返す
5.使用した対象資材を結果とする

サンプル(Excel2013)
http://www.eathract.com/school/school_sample.zip

※いけてる感じするのですが、上記の考え方で対応できないパターンがあるような気もするんですよねぇ〜

(eathract) 2016/04/02(土) 10:57



とりあえず、ランダム案の例。 実際の利用状況に近い、選択肢の多いパターンでどうなるやら。
なお、製品候補は大きい方からどんどん決定するので、実は小さい方と入れ替えれば…、というところまで考慮していません。
それでもこれだけ複雑になるわけですから。

 Sub test()
    Dim ARS As Object
    Dim ARZ As Object
    Dim wkS As Worksheet
    Dim wkZ As Worksheet
    Dim cw As String
    Dim cOK As String
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim m As Long
    Dim iw As Long
    Dim iOK As Long
    Dim iSu As Long
    Dim iCou As Long
    Dim iFlag As Long
    Dim iMaxS As Long
    Dim jMax As Long
    Dim dw As Double
    Dim dM As Double
    Dim dOK As Double
    Dim dTotal As Double
    Dim dDimZ() As Double
    Dim dS() As Double
    Dim dZ() As Double
    Dim dZ2() As Double

    Set ARS = CreateObject("System.Collections.ArrayList")
    Set ARZ = CreateObject("System.Collections.ArrayList")
    Set wkS = Sheets("最適計算")
    Set wkZ = Sheets("在庫")
    wkS.Columns("D:E").ClearContents
    wkS.Range("D1:E1").Value = Array("SIYOnagasa1", "SIYOkazu")

    With wkS
        For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
            cw = .Cells(i, "A").Value
            If Not ARS.Contains(cw) Then
                ARS.Add cw
            End If
        Next i
    End With

    For i = 0 To ARS.Count - 1
        iOK = 999
        dOK = 99999
        dM = 99999
        iMaxS = 0
        iCou = 0
        dTotal = 0

        '製品配列作成
        For j = 2 To wkS.Cells(wkS.Rows.Count, "A").End(xlUp).Row
            If ARS(i) = wkS.Cells(j, "A").Value Then
                For k = 1 To wkS.Cells(j, "B").Value
                    ReDim Preserve dS(iMaxS)
                    dS(iMaxS) = wkS.Cells(j, "C").Value
                    If dS(iMaxS) < dM Then
                        dM = dS(iMaxS)
                    End If
                    iMaxS = iMaxS + 1
                Next k
                dTotal = dTotal + wkS.Cells(j, "B").Value * wkS.Cells(j, "C").Value
            End If
        Next j

        jMax = 0
        ReDim dDimZ(2, 0)

        '在庫配列作成
        For j = 2 To wkZ.Cells(wkZ.Rows.Count, "A").End(xlUp).Row
            If ARS(i) = wkZ.Cells(j, "A").Value Then
                If dM <= wkZ.Cells(j, "C").Value Then
                    ReDim Preserve dDimZ(2, jMax)
                    dDimZ(0, jMax) = wkZ.Cells(j, "B").Value
                    dDimZ(1, jMax) = wkZ.Cells(j, "C").Value
                    If dTotal / dDimZ(1, jMax) < dDimZ(0, jMax) Then
                        dDimZ(0, jMax) = Application.RoundUp(dTotal / dDimZ(1, jMax), 0)
                    End If
                    iCou = iCou + dDimZ(0, jMax)
                    jMax = jMax + 1
                End If
            End If
        Next j

        '計算用在庫配列
        iw = 0
        ReDim dZ(iCou - 1)
        For j = 0 To jMax - 1
            For k = 1 To dDimZ(0, j)
                dZ(iw) = dDimZ(1, j)
                iw = iw + 1
            Next k
        Next j

        'ランダムに在庫選択
        For j = 0 To 99999
            Randomize
            dw = 0
            cw = String(iCou, "0")
            For k = 1 To iCou
                If Rnd() * 2 < 1 Then
                    Mid(cw, k, 1) = "1"
                    dw = dw + dZ(k - 1)
                    If dTotal <= dw Then
                        Exit For
                    End If
                End If
            Next k
            If k <= iCou Then
                '製品合計<素材合計の候補
                iSu = 0
                For k = 0 To iw - 1
                    If Mid(cw, k + 1, 1) = "1" Then
                        ReDim Preserve dZ2(iSu)
                        dZ2(iSu) = dZ(k)
                        iSu = iSu + 1
                    End If
                Next k

                '切断可能かチェック
                iFlag = 0
                For k = 0 To UBound(dS)
                    For m = 0 To iSu - 1
                        If dS(k) < dZ2(m) Then
                            dZ2(m) = dZ2(m) - dS(k)
                            Exit For
                        End If
                    Next m
                    If iSu <= m Then
                        iFlag = 1
                        Exit For
                    End If
                Next k

                '切断可能だったので、最適候補と比較
                If iFlag = 0 Then
                    dw = 0
                    For k = 0 To iSu - 1
                        dw = dw + dZ2(k)
                    Next k
                    If iSu < iOK Then
                        iOK = iSu
                        cOK = cw
                        dOK = dw
                    ElseIf iSu = iOK Then
                        If dw < dOK Then
                            iOK = iSu
                            cOK = cw
                            dOK = dw
                        End If
                    End If
                End If
            End If
        Next j

        '結果表示
        For j = 2 To wkS.Cells(wkS.Rows.Count, "A").End(xlUp).Row
            If wkS.Cells(j, "A").Value = ARS(i) Then
                iw = 0
                For k = iCou - 1 To 0 Step -1
                    If Mid(cOK, k + 1, 1) = "1" Then
                        If wkS.Cells(j + iw, "D").Value = dZ(k) Then
                            wkS.Cells(j + iw, "E").Value = wkS.Cells(j + iw, "E").Value + 1
                        Else
                            If wkS.Cells(j + iw, "D").Value <> "" Then
                                iw = iw + 1
                            End If
                            wkS.Cells(j + iw, "D").Value = dZ(k)
                            wkS.Cells(j + iw, "E").Value = 1
                        End If
                    End If
                Next k
                Exit For
            End If
        Next j
    Next i

    Set ARS = Nothing
    Set ARZ = Nothing
 End Sub
(???) 2016/04/04(月) 17:44

(γ)さん及び皆様ご指摘ありがとうございます。
考えていたより難問だと思い知らされました。
安易な回答、分かり辛い質問や説明で申し訳ないです。

(eathract)さん、(???)さんロジックありがとうございます。
実際のExcelに当てはめて検証してみたいと思います。
検証するのに時間が掛かると思いますが、
終わりましたらまたこちらに回答したいと思います。

(mana) 2016/04/04(月) 20:09


是非、思ったとおりに行かなかったパターンを見つけて、ご提示ください。

改良できる点として考えているのが、使用する在庫数が31(頑張れば32)個以下の場合に限り、総当たりもできるなぁ、という点。
ランダム使っている直前に、iCouの判定を加えることで可能です。あまり組合せが多くないようでしたら、考えてみてください。
(???) 2016/04/05(火) 08:56


思ったより簡単に変更できたので、改良案の総当たり版です。
こっちで処理中止してしまう場合、ランダム版を試してみてください。

 Sub test2()
    Dim ARS As Object
    Dim wkS As Worksheet
    Dim wkZ As Worksheet
    Dim cw As String
    Dim cOK As String
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim m As Long
    Dim iw As Long
    Dim iOK As Long
    Dim iSu As Long
    Dim iCou As Long
    Dim iFlag As Long
    Dim iMaxS As Long
    Dim jMax As Long
    Dim dw As Double
    Dim dM As Double
    Dim dOK As Double
    Dim dTotal As Double
    Dim dDimZ() As Double
    Dim dS() As Double
    Dim dZ() As Double
    Dim dZ2() As Double

    Set ARS = CreateObject("System.Collections.ArrayList")
    Set wkS = Sheets("最適計算")
    Set wkZ = Sheets("在庫")
    wkS.Columns("D:E").ClearContents
    wkS.Range("D1:E1").Value = Array("SIYOnagasa1", "SIYOkazu")

    With wkS
        For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
            cw = .Cells(i, "A").Value
            If Not ARS.Contains(cw) Then
                ARS.Add cw
            End If
        Next i
    End With

    For i = 0 To ARS.Count - 1
        iOK = 999
        dOK = 99999
        dM = 99999
        iMaxS = 0
        iCou = 0
        dTotal = 0

        '製品配列作成
        For j = 2 To wkS.Cells(wkS.Rows.Count, "A").End(xlUp).Row
            If ARS(i) = wkS.Cells(j, "A").Value Then
                For k = 1 To wkS.Cells(j, "B").Value
                    ReDim Preserve dS(iMaxS)
                    dS(iMaxS) = wkS.Cells(j, "C").Value
                    If dS(iMaxS) < dM Then
                        dM = dS(iMaxS)
                    End If
                    iMaxS = iMaxS + 1
                Next k
                dTotal = dTotal + wkS.Cells(j, "B").Value * wkS.Cells(j, "C").Value
            End If
        Next j

        jMax = 0
        ReDim dDimZ(2, 0)

        '在庫配列作成
        For j = 2 To wkZ.Cells(wkZ.Rows.Count, "A").End(xlUp).Row
            If ARS(i) = wkZ.Cells(j, "A").Value Then
                If dM <= wkZ.Cells(j, "C").Value Then
                    ReDim Preserve dDimZ(2, jMax)
                    dDimZ(0, jMax) = wkZ.Cells(j, "B").Value
                    dDimZ(1, jMax) = wkZ.Cells(j, "C").Value
                    If dTotal / dDimZ(1, jMax) < dDimZ(0, jMax) Then
                        dDimZ(0, jMax) = Application.RoundUp(dTotal / dDimZ(1, jMax), 0)
                    End If
                    iCou = iCou + dDimZ(0, jMax)
                    jMax = jMax + 1
                End If
            End If
        Next j

        If 31 < iCou Then
            MsgBox "在庫の組合せ数が限界を超えるため、処理中止します。", vbCritical, "エラー"
            End
        End If

        '計算用在庫配列
        iw = 0
        ReDim dZ(iCou - 1)
        For j = 0 To jMax - 1
            For k = 1 To dDimZ(0, j)
                dZ(iw) = dDimZ(1, j)
                iw = iw + 1
            Next k
        Next j

        For j = 0 To 2 ^ iCou - 1
            dw = 0
            cw = String(iCou, "0")
            For k = 1 To iCou
                If (2 ^ (k - 1) And j) <> 0 Then
                    Mid(cw, k, 1) = "1"
                    dw = dw + dZ(k - 1)
                    If dTotal <= dw Then
                        Exit For
                    End If
                End If
            Next k
            If k <= iCou Then
                '製品合計<素材合計の候補
                iSu = 0
                For k = 0 To iw - 1
                    If Mid(cw, k + 1, 1) = "1" Then
                        ReDim Preserve dZ2(iSu)
                        dZ2(iSu) = dZ(k)
                        iSu = iSu + 1
                    End If
                Next k

                '切断可能かチェック
                iFlag = 0
                For k = 0 To UBound(dS)
                    For m = 0 To iSu - 1
                        If dS(k) < dZ2(m) Then
                            dZ2(m) = dZ2(m) - dS(k)
                            Exit For
                        End If
                    Next m
                    If iSu <= m Then
                        iFlag = 1
                        Exit For
                    End If
                Next k

                '切断可能だったので、最適候補と比較
                If iFlag = 0 Then
                    dw = 0
                    For k = 0 To iSu - 1
                        dw = dw + dZ2(k)
                    Next k
                    If iSu < iOK Then
                        iOK = iSu
                        cOK = cw
                        dOK = dw
                    ElseIf iSu = iOK Then
                        If dw < dOK Then
                            iOK = iSu
                            cOK = cw
                            dOK = dw
                        End If
                    End If
                End If
            End If
        Next j

        '結果表示
        For j = 2 To wkS.Cells(wkS.Rows.Count, "A").End(xlUp).Row
            If wkS.Cells(j, "A").Value = ARS(i) Then
                iw = 0
                For k = iCou - 1 To 0 Step -1
                    If Mid(cOK, k + 1, 1) = "1" Then
                        If wkS.Cells(j + iw, "D").Value = dZ(k) Then
                            wkS.Cells(j + iw, "E").Value = wkS.Cells(j + iw, "E").Value + 1
                        Else
                            If wkS.Cells(j + iw, "D").Value <> "" Then
                                iw = iw + 1
                            End If
                            wkS.Cells(j + iw, "D").Value = dZ(k)
                            wkS.Cells(j + iw, "E").Value = 1
                        End If
                    End If
                Next k
                Exit For
            End If
        Next j
    Next i

    Set ARS = Nothing
 End Sub
(???) 2016/04/05(火) 09:49

総当たり案ですが、バグがありました。
製品Bのパターンでは、3つの製品で合計5840の長さが必要なのですが、これを3000の在庫2つ見つけた段階で十分と判断し、ループを抜けてました。
これだと3番目の製品を切り出せないのに、OKと判定してしまいました。
ループ数を減らす工夫が仇になってしまっていたので、途中抜けを止めて対応しています。

ついでに、デバッグのために実際どう切り出すよう計算したのか見たかったので、「明細」シートを追加しています。
予め、このシートを追加しておいてから、以下のマクロを実行してみてください。

また、在庫の並びが昇順なのに、結果表示は降順だったのが気に入らなかったので、在庫と同じ順で結果表示するようにしました。
長いものから表示したい場合、在庫データを降順で並べ替えてください。
(seihinは昇順、nagasaは降順を指定)

 Sub test3()
    Dim ARS As Object
    Dim wkM As Worksheet
    Dim wkS As Worksheet
    Dim wkZ As Worksheet
    Dim cw As String
    Dim cOK As String
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim m As Long
    Dim iw As Long
    Dim iOK As Long
    Dim iSu As Long
    Dim iCou As Long
    Dim iFlag As Long
    Dim iMaxS As Long
    Dim jMax As Long
    Dim dw As Double
    Dim dM As Double
    Dim dOK As Double
    Dim dTotal As Double
    Dim dDimZ() As Double
    Dim dS() As Double
    Dim dZ() As Double
    Dim dZ2() As Double

    Set ARS = CreateObject("System.Collections.ArrayList")
    Set wkM = Sheets("明細")
    Set wkS = Sheets("最適計算")
    Set wkZ = Sheets("在庫")

    With wkM
        iw = .Cells(.Rows.Count, "A").End(xlUp).Row
        If 1 < iw Then
            .Rows("2:" & iw).Delete
        End If
        .Range("A1:E1").Value = Array("seihin", "使用在庫", "使用size", "使用残", "使用kazu")
    End With

    With wkS
        For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
            cw = .Cells(i, "A").Value
            If Not ARS.Contains(cw) Then
                ARS.Add cw
            End If
        Next i
        .Columns("D:E").ClearContents
        .Range("D1:E1").Value = Array("SIYOnagasa1", "SIYOkazu")
    End With

    For i = 0 To ARS.Count - 1
        cOK = ""
        dM = 99999
        dOK = 99999
        iOK = 999
        iCou = 0
        iMaxS = 0
        dTotal = 0

        '製品配列作成
        For j = 2 To wkS.Cells(wkS.Rows.Count, "A").End(xlUp).Row
            If ARS(i) = wkS.Cells(j, "A").Value Then
                For k = 1 To wkS.Cells(j, "B").Value
                    ReDim Preserve dS(iMaxS)
                    dS(iMaxS) = wkS.Cells(j, "C").Value
                    If dS(iMaxS) < dM Then
                        dM = dS(iMaxS)
                    End If
                    iMaxS = iMaxS + 1
                Next k
                dTotal = dTotal + wkS.Cells(j, "B").Value * wkS.Cells(j, "C").Value
            End If
        Next j

        jMax = 0
        ReDim dDimZ(1, 0)

        '在庫配列作成
        For j = 2 To wkZ.Cells(wkZ.Rows.Count, "A").End(xlUp).Row
            If ARS(i) = wkZ.Cells(j, "A").Value Then
                If dM <= wkZ.Cells(j, "C").Value Then
                    ReDim Preserve dDimZ(1, jMax)
                    dDimZ(0, jMax) = wkZ.Cells(j, "B").Value
                    dDimZ(1, jMax) = wkZ.Cells(j, "C").Value
                    If dTotal / dDimZ(1, jMax) < dDimZ(0, jMax) Then
                        dDimZ(0, jMax) = Application.RoundUp(dTotal / dDimZ(1, jMax), 0)
                    End If
                    iCou = iCou + dDimZ(0, jMax)
                    jMax = jMax + 1
                End If
            End If
        Next j

        If 31 < iCou Then
            MsgBox "在庫の組合せ数が限界を超えるため、処理中止します。", vbCritical, "エラー"
            End
        End If

        '計算用在庫配列
        iw = 0
        ReDim dZ(iCou - 1)
        For j = 0 To jMax - 1
            For k = 1 To dDimZ(0, j)
                dZ(iw) = dDimZ(1, j)
                iw = iw + 1
            Next k
        Next j
        For j = 1 To 2 ^ iCou - 1
            dw = 0
            cw = String(iCou, "0")
            For k = 1 To iCou
                If (2 ^ (k - 1) And j) <> 0 Then
                    Mid(cw, k, 1) = "1"
                    dw = dw + dZ(k - 1)
                End If
            Next k

            '製品合計<素材合計の候補
            iSu = 0
            For k = 0 To iw - 1
                If Mid(cw, k + 1, 1) = "1" Then
                    ReDim Preserve dZ2(iSu)
                    dZ2(iSu) = dZ(k)
                    iSu = iSu + 1
                End If
            Next k

            '切断可能かチェック
            iFlag = 0
            For k = 0 To UBound(dS)
                For m = 0 To iSu - 1
                    If dS(k) < dZ2(m) Then
                        dZ2(m) = dZ2(m) - dS(k)
                        Exit For
                    End If
                Next m
                If iSu <= m Then
                    iFlag = 1
                    Exit For
                End If
            Next k

            '切断可能だったので、最適候補と比較
            If iFlag = 0 Then
                dw = 0
                For k = 0 To iSu - 1
                    dw = dw + dZ2(k)
                Next k
                If iSu <= iOK Then
                    If dw < dOK Then
                        iOK = iSu
                        cOK = cw
                        dOK = dw
                    End If
                End If
            End If
        Next j

        '結果表示
        For j = 2 To wkS.Cells(wkS.Rows.Count, "A").End(xlUp).Row
            If wkS.Cells(j, "A").Value = ARS(i) Then
                iw = 0
                For k = 0 To iCou - 1
                    If Mid(cOK, k + 1, 1) = "1" Then
                        If wkS.Cells(j + iw, "D").Value = dZ(k) Then
                            wkS.Cells(j + iw, "E").Value = wkS.Cells(j + iw, "E").Value + 1
                        Else
                            If wkS.Cells(j + iw, "D").Value <> "" Then
                                iw = iw + 1
                            End If
                            wkS.Cells(j + iw, "D").Value = dZ(k)
                            wkS.Cells(j + iw, "E").Value = 1
                        End If
                    End If
                Next k
                Exit For
            End If
        Next j

        '明細表示
        With wkM
            iw = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
            iSu = 0
            For k = 0 To iCou - 1
                If Mid(cOK, k + 1, 1) = "1" Then
                    dZ2(iSu) = dZ(k)
                    .Cells(iw + iSu, "A").Value = ARS(i)
                    .Cells(iw + iSu, "B").Value = dZ(k)
                    .Cells(iw + iSu, "C").FormulaR1C1 = "=Sum(RC[3]:RC[101])"
                    .Cells(iw + iSu, "D").FormulaR1C1 = "=RC[-2]-RC[-1]"
                    .Cells(iw + iSu, "E").FormulaR1C1 = "=Count(RC[1]:RC[99])"
                    iSu = iSu + 1
                End If
            Next k

            For k = 0 To UBound(dS)
                For m = 0 To iSu - 1
                    If dS(k) < dZ2(m) Then
                        dZ2(m) = dZ2(m) - dS(k)
                        .Cells(iw + m, "A").End(xlToRight).Offset(0, 1).Value = dS(k)
                        Exit For
                    End If
                Next m
            Next k
        End With
    Next i

    Set ARS = Nothing
 End Sub
(???) 2016/04/05(火) 17:18

 ???さんへ
 初めのランダム版にも「明細」シートを追加された方が
 長さの組み合わせが分かりやすいと思います。
(pack) 2016/04/06(水) 06:26

では比較用に、ランダム案の明細付きコードも書いておきますね。
ランダム案の場合、jのループ数を増減すると、結果が変わってきます。多い方が正確になりますが、時間がかかります。

 Sub test4()
    Dim ARS As Object
    Dim wkM As Worksheet
    Dim wkS As Worksheet
    Dim wkZ As Worksheet
    Dim cw As String
    Dim cOK As String
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim m As Long
    Dim iw As Long
    Dim iOK As Long
    Dim iSu As Long
    Dim iCou As Long
    Dim iFlag As Long
    Dim iMaxS As Long
    Dim jMax As Long
    Dim dw As Double
    Dim dM As Double
    Dim dOK As Double
    Dim dTotal As Double
    Dim dDimZ() As Double
    Dim dS() As Double
    Dim dZ() As Double
    Dim dZ2() As Double

    Randomize

    Set ARS = CreateObject("System.Collections.ArrayList")
    Set wkM = Sheets("明細")
    Set wkS = Sheets("最適計算")
    Set wkZ = Sheets("在庫")

    With wkM
        iw = .Cells(.Rows.Count, "A").End(xlUp).Row
        If 1 < iw Then
            .Rows("2:" & iw).Delete
        End If
        .Range("A1:E1").Value = Array("seihin", "使用在庫", "使用size", "使用残", "使用kazu")
    End With

    With wkS
        For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
            cw = .Cells(i, "A").Value
            If Not ARS.Contains(cw) Then
                ARS.Add cw
            End If
        Next i
        .Columns("D:E").ClearContents
        .Range("D1:E1").Value = Array("SIYOnagasa1", "SIYOkazu")
    End With

    For i = 0 To ARS.Count - 1
        cOK = ""
        dM = 99999
        dOK = 99999
        iOK = 999
        iCou = 0
        iMaxS = 0
        dTotal = 0

        '製品配列作成
        For j = 2 To wkS.Cells(wkS.Rows.Count, "A").End(xlUp).Row
            If ARS(i) = wkS.Cells(j, "A").Value Then
                For k = 1 To wkS.Cells(j, "B").Value
                    ReDim Preserve dS(iMaxS)
                    dS(iMaxS) = wkS.Cells(j, "C").Value
                    If dS(iMaxS) < dM Then
                        dM = dS(iMaxS)
                    End If
                    iMaxS = iMaxS + 1
                Next k
                dTotal = dTotal + wkS.Cells(j, "B").Value * wkS.Cells(j, "C").Value
            End If
        Next j

        jMax = 0
        ReDim dDimZ(1, 0)

        '在庫配列作成
        For j = 2 To wkZ.Cells(wkZ.Rows.Count, "A").End(xlUp).Row
            If ARS(i) = wkZ.Cells(j, "A").Value Then
                If dM <= wkZ.Cells(j, "C").Value Then
                    ReDim Preserve dDimZ(1, jMax)
                    dDimZ(0, jMax) = wkZ.Cells(j, "B").Value
                    dDimZ(1, jMax) = wkZ.Cells(j, "C").Value
                    If dTotal / dDimZ(1, jMax) < dDimZ(0, jMax) Then
                        dDimZ(0, jMax) = Application.RoundUp(dTotal / dDimZ(1, jMax), 0)
                    End If
                    iCou = iCou + dDimZ(0, jMax)
                    jMax = jMax + 1
                End If
            End If
        Next j

        '計算用在庫配列
        iw = 0
        ReDim dZ(iCou - 1)
        For j = 0 To jMax - 1
            For k = 1 To dDimZ(0, j)
                dZ(iw) = dDimZ(1, j)
                iw = iw + 1
            Next k
        Next j

        'ランダムに在庫選択
        For j = 0 To 99999
            dw = 0
            cw = String(iCou, "0")
            For k = 1 To iCou
                If Rnd() * 2 < 1 Then
                    Mid(cw, k, 1) = "1"
                End If
            Next k

            '製品合計<素材合計の候補
            iSu = 0
            For k = 0 To iw - 1
                If Mid(cw, k + 1, 1) = "1" Then
                    ReDim Preserve dZ2(iSu)
                    dZ2(iSu) = dZ(k)
                    iSu = iSu + 1
                End If
            Next k

            '切断可能かチェック
            iFlag = 0
            For k = 0 To UBound(dS)
                For m = 0 To iSu - 1
                    If dS(k) < dZ2(m) Then
                        dZ2(m) = dZ2(m) - dS(k)
                        Exit For
                    End If
                Next m
                If iSu <= m Then
                    iFlag = 1
                    Exit For
                End If
            Next k

            '切断可能だったので、最適候補と比較
            If iFlag = 0 Then
                dw = 0
                For k = 0 To iSu - 1
                    dw = dw + dZ2(k)
                Next k
                If iSu <= iOK Then
                    If dw < dOK Then
                        iOK = iSu
                        cOK = cw
                        dOK = dw
                    End If
                End If
            End If
        Next j

        '結果表示
        For j = 2 To wkS.Cells(wkS.Rows.Count, "A").End(xlUp).Row
            If wkS.Cells(j, "A").Value = ARS(i) Then
                iw = 0
                For k = 0 To iCou - 1
                    If Mid(cOK, k + 1, 1) = "1" Then
                        If wkS.Cells(j + iw, "D").Value = dZ(k) Then
                            wkS.Cells(j + iw, "E").Value = wkS.Cells(j + iw, "E").Value + 1
                        Else
                            If wkS.Cells(j + iw, "D").Value <> "" Then
                                iw = iw + 1
                            End If
                            wkS.Cells(j + iw, "D").Value = dZ(k)
                            wkS.Cells(j + iw, "E").Value = 1
                        End If
                    End If
                Next k
                Exit For
            End If
        Next j

        '明細表示
        With wkM
            iw = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
            iSu = 0
            For k = 0 To iCou - 1
                If Mid(cOK, k + 1, 1) = "1" Then
                    ReDim Preserve dZ2(iSu)
                    dZ2(iSu) = dZ(k)
                    .Cells(iw + iSu, "A").Value = ARS(i)
                    .Cells(iw + iSu, "B").Value = dZ(k)
                    .Cells(iw + iSu, "C").FormulaR1C1 = "=Sum(RC[3]:RC[101])"
                    .Cells(iw + iSu, "D").FormulaR1C1 = "=RC[-2]-RC[-1]"
                    .Cells(iw + iSu, "E").FormulaR1C1 = "=Count(RC[1]:RC[99])"
                    iSu = iSu + 1
                End If
            Next k

            For k = 0 To UBound(dS)
                For m = 0 To iSu - 1
                    If dS(k) < dZ2(m) Then
                        dZ2(m) = dZ2(m) - dS(k)
                        .Cells(iw + m, "A").End(xlToRight).Offset(0, 1).Value = dS(k)
                        Exit For
                    End If
                Next m
            Next k
        End With
    Next i

    Set ARS = Nothing
 End Sub
(???) 2016/04/06(水) 10:28

試していて気づいたのですが、例えばA在庫の2500を在庫切れ(0)にした場合、A製品は3000*2使用(残736)になります。
しかし、在庫を元のように昇順のままにしておくと、1900*3(残436)になり、より効率的になります。

表示順は元と逆になりますが、在庫は小さい方から並べるのが良いようですね。
(???) 2016/04/06(水) 11:32


更に突っ込んだ考察なぞ。

在庫A:2500を2300に変えると、提示したロジックでは1900*3(残436)という結果になります。
しかし、3000という素材に着目し、最適解を探すと、3000+2300(残36)がベストかと思います。
このあたりがまだ改善余地あり、と思えるところですねぇ。

791+342*3+327*3+200 = 2998(残2)
791+574*2+327 = 2266(残34)

まぁ、より複雑なロジックになってしまう訳ですが。
(???) 2016/04/06(水) 13:16


(eathract)さんだと長いものから使用するので、本数は少なく済む。
(???)さんだと歩留りはよくなるが(eathract)さんより本数は多くなる。
感じになる為、ともに結果は違えど希望に近いものが算出されました。
両パターンを用途に分け使用したいと思います。

また、(???)さんのロジックだと下記seihin(C)のような在庫が0を含む場合??
は正常に値が算出できないようでした。

今のままでも十分なくらいですが、参考までに下記条件を追加する事は可能でしょうか?

3000の長さを起点に、1つの製品が3000を超えるものがある場合は3000より長い在庫を使う。
3000以下の場合は3000以下の在庫を使う。
下記でいうseihin(D)のような感じにしたいです。

結果の内訳
4900*3=(3512+1001)*3
2000*1=(1001+688)*1
2000*1=(1001+460+460)*1
2000*1=(460*4)*1
2000*1=(460*4)*1

在庫シート

          A      B     C
  1行目 seihin zaiko nagasa
  2行目   A      10   1900
  3行目   A       1   2000
  4行目   A       1   2500
  5行目   A      30   3000
  6行目   B     100    500
  7行目   B     200   1000
  8行目   B      10   2000
  9行目   B      20   3000
 10行目   C       0   2000
 11行目   C      28   3000
 12行目   C       0   6000
 13行目   D      65   2000
 14行目   D     110   3000
 15行目   D       5   4300
 16行目   D       5   4900

最適計算シート

          A      B     C     D            E
  1行目 seihin kazu  nagasa  SIYOnagasa1  SIYOkazu
  2行目   A       2    791    3000           1
  3行目   A       2    574    2500           1
  4行目   A       3    342
  5行目   A       4    327
  6行目   A       1    200
  7行目   B       2   2180    3000           2
  8行目   B       1   1480    2000           1
  9行目   C      20   2012    3000          26
 10行目   C      10   1482
 11行目   C       1   1163
 12行目   C       1    809
 13行目   D       3   3512    2000           4
 14行目   D       5   1001    4900           3
 15行目   D       1    688
 16行目   D      10    460

(mana) 2016/04/06(水) 17:37


 製品の種類が増えてきてますが、在庫の種類に一致する必要はあるのですか?

 >割り当てたnagasaの端数で出たら、別seihinになるべく使用できるようにする。
 とあるので、
 はじめからどの製品も任意の在庫から切ってもよさそうですが。

(pack) 2016/04/07(木) 08:09


まず、製品Cのケースで結果が得られなかったのは、0件が問題ではなく、ロジックで必要以上に在庫数を削って計算したためです。
在庫配列作成、の部分で、在庫候補を減らしている箇所を削除すれば、答えが得られるようになります。

3000以下の製品は長い在庫は使わないよう、制限を追加した版です。元が長くても、残材が短いならば、使うようになっています。
他にも、気になった部分を修正してあります。

組合せ数が膨大になってきたので、総当たりでは待ちきれないくらい時間がかかるので、ランダム案だけ挙げますね。
(小数点以下を想定してDouble型で計算していますが、これをLong型に変えれば、少し速くできます)

 Sub test5()
    Const LIMIT = 3000
    Dim ARS As Object
    Dim wkM As Worksheet
    Dim wkS As Worksheet
    Dim wkZ As Worksheet
    Dim cw As String
    Dim cOK As String
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim m As Long
    Dim iw As Long
    Dim iOk As Long
    Dim iSu As Long
    Dim iCou As Long
    Dim iZ2() As Long
    Dim iFlag As Long
    Dim iMaxS As Long
    Dim jMax As Long
    Dim dw As Double
    Dim dM As Double
    Dim dOk As Double
    Dim dTotal As Double
    Dim dDimZ() As Double
    Dim dS() As Double
    Dim dZ() As Double
    Dim dZ2() As Double

    Randomize

    Set ARS = CreateObject("System.Collections.ArrayList")
    Set wkM = Sheets("明細")
    Set wkS = Sheets("最適計算")
    Set wkZ = Sheets("在庫")

    With wkM
        iw = .Cells(.Rows.Count, "A").End(xlUp).Row
        If 1 < iw Then
            .Rows("2:" & iw).Delete
        End If
        .Range("A1:E1").Value = Array("seihin", "使用在庫", "使用size", "使用残", "使用kazu")
    End With

    With wkS
        For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
            cw = .Cells(i, "A").Value
            If Not ARS.Contains(cw) Then
                ARS.Add cw
            End If
        Next i
        .Columns("D:E").ClearContents
        .Range("D1:E1").Value = Array("SIYOnagasa1", "SIYOkazu")
    End With

    For i = 0 To ARS.Count - 1
        cOK = ""
        dM = 99999
        dOk = 99999
        iOk = 999
        iCou = 0
        iMaxS = 0
        dTotal = 0

        '製品配列作成
        For j = 2 To wkS.Cells(wkS.Rows.Count, "A").End(xlUp).Row
            If ARS(i) = wkS.Cells(j, "A").Value Then
                For k = 1 To wkS.Cells(j, "B").Value
                    ReDim Preserve dS(iMaxS)
                    dS(iMaxS) = wkS.Cells(j, "C").Value
                    If dS(iMaxS) < dM Then
                        dM = dS(iMaxS)
                    End If
                    iMaxS = iMaxS + 1
                Next k
                dTotal = dTotal + wkS.Cells(j, "B").Value * wkS.Cells(j, "C").Value
            End If
        Next j

        jMax = 0
        ReDim dDimZ(1, 0)

        '在庫配列作成
        For j = 2 To wkZ.Cells(wkZ.Rows.Count, "A").End(xlUp).Row
            If ARS(i) = wkZ.Cells(j, "A").Value Then
                If dM <= wkZ.Cells(j, "C").Value Then
                    ReDim Preserve dDimZ(1, jMax)
                    dDimZ(0, jMax) = wkZ.Cells(j, "B").Value
                    dDimZ(1, jMax) = wkZ.Cells(j, "C").Value
                    If iMaxS < dDimZ(0, jMax) Then
                        dDimZ(0, jMax) = iMaxS
                    End If
                    iCou = iCou + dDimZ(0, jMax)
                    jMax = jMax + 1
                End If
            End If
        Next j

        '計算用在庫配列
        iw = 0
        ReDim dZ(iCou - 1)
        For j = 0 To jMax - 1
            For k = 1 To dDimZ(0, j)
                dZ(iw) = dDimZ(1, j)
                iw = iw + 1
            Next k
        Next j

        'ランダムに在庫選択
        For j = 0 To 999999
            dw = 0
            cw = String(iCou, "0")
            For k = 1 To iCou
                If Rnd() * 2 < 1 Then
                    Mid(cw, k, 1) = "1"
                End If
            Next k

            '製品合計<素材合計の候補
            iSu = 0
            For k = 0 To iw - 1
                If Mid(cw, k + 1, 1) = "1" Then
                    ReDim Preserve dZ2(iSu)
                    dZ2(iSu) = dZ(k)
                    iSu = iSu + 1
                End If
            Next k

            If 0 < iSu Then
                ReDim iZ2(iSu - 1)

                '切断可能かチェック
                iFlag = 0
                For k = 0 To UBound(dS)
                    For m = 0 To iSu - 1
                        If dS(k) < dZ2(m) Then
                            If LIMIT < dS(k) Then
                                dZ2(m) = dZ2(m) - dS(k)
                                iZ2(m) = 1
                                Exit For
                            ElseIf dZ2(m) <= LIMIT Then
                                dZ2(m) = dZ2(m) - dS(k)
                                iZ2(m) = 1
                                Exit For
                            End If
                        End If
                    Next m
                    If iSu <= m Then
                        iFlag = 1
                        Exit For
                    End If
                Next k
            Else
                iFlag = 1
            End If

            '切断可能だったので、最適候補と比較
            If iFlag = 0 Then
                '使わなかった在庫候補を消す
                For k = 0 To iSu - 1
                    If iZ2(k) = 0 Then
                        Mid(cw, k + 1, 1) = "0"
                    End If
                Next k

                dw = 0
                For k = 0 To iSu - 1
                    dw = dw + dZ2(k)
                Next k
                If dw < dOk Then
                    iOk = iSu
                    cOK = cw
                    dOk = dw
                End If
            End If
        Next j

        '結果表示
        For j = 2 To wkS.Cells(wkS.Rows.Count, "A").End(xlUp).Row
            If wkS.Cells(j, "A").Value = ARS(i) Then
                iw = 0
                For k = 0 To iCou - 1
                    If Mid(cOK, k + 1, 1) = "1" Then
                        If wkS.Cells(j + iw, "D").Value = dZ(k) Then
                            wkS.Cells(j + iw, "E").Value = wkS.Cells(j + iw, "E").Value + 1
                        Else
                            If wkS.Cells(j + iw, "D").Value <> "" Then
                                iw = iw + 1
                            End If
                            wkS.Cells(j + iw, "D").Value = dZ(k)
                            wkS.Cells(j + iw, "E").Value = 1
                        End If
                    End If
                Next k
                Exit For
            End If
        Next j

        '明細表示
        With wkM
            iw = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
            iSu = 0
            For k = 0 To iCou - 1
                If Mid(cOK, k + 1, 1) = "1" Then
                    ReDim Preserve dZ2(iSu)
                    dZ2(iSu) = dZ(k)
                    .Cells(iw + iSu, "A").Value = ARS(i)
                    .Cells(iw + iSu, "B").Value = dZ(k)
                    .Cells(iw + iSu, "C").FormulaR1C1 = "=Sum(RC[3]:RC[101])"
                    .Cells(iw + iSu, "D").FormulaR1C1 = "=RC[-2]-RC[-1]"
                    .Cells(iw + iSu, "E").FormulaR1C1 = "=Count(RC[1]:RC[99])"
                    iSu = iSu + 1
                End If
            Next k

            For k = 0 To UBound(dS)
                For m = 0 To iSu - 1
                    If dS(k) < dZ2(m) Then
                        If LIMIT < dS(k) Then
                            dZ2(m) = dZ2(m) - dS(k)
                            .Cells(iw + m, "A").End(xlToRight).Offset(0, 1).Value = dS(k)
                            Exit For
                        ElseIf dZ2(m) <= LIMIT Then
                            dZ2(m) = dZ2(m) - dS(k)
                            .Cells(iw + m, "A").End(xlToRight).Offset(0, 1).Value = dS(k)
                            Exit For
                        End If
                    End If
                Next m
            Next k
        End With
    Next i

    Set ARS = Nothing
 End Sub
(???) 2016/04/07(木) 12:13

ちなみに、製品Dの例だと、
4900*3+2000*4-20829 = 残1871

との事ですが、ランダム計算で、
4300*3+3000+2000*3-20829 = 残1071

とか算出してきました。最適ではなくとも、十分いける感じですねぇ。
(???) 2016/04/07(木) 12:28


(???)さんありがとうございます。
私が考えるとおりの結果です。

最後に申し訳ありませんが、引き当てるものがまったくない場合エラーとなります。

回避可能でしょうか?
また、「在庫なし」等の文字列で表示させる事は可能でしょうか?

在庫シート

          A      B     C
  1行目 seihin zaiko nagasa
  2行目   F       0   1000

最適計算シート

          A      B     C      D            E
  1行目 seihin kazu  nagasa  SIYOnagasa1  SIYOkazu
  2行目   F      20    257     在庫なし     
  3行目   F      10    144

(mana) 2016/04/08(金) 09:25


加工できなかった場合のメッセージを追加してみました。いかがでしょうか。

 Sub test6()
    Const LIMIT = 3000
    Dim ARS As Object
    Dim wkM As Worksheet
    Dim wkS As Worksheet
    Dim wkZ As Worksheet
    Dim cw As String
    Dim cOK As String
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim m As Long
    Dim iw As Long
    Dim iOk As Long
    Dim iSu As Long
    Dim iCou As Long
    Dim iZ2() As Long
    Dim iFlag As Long
    Dim iMaxS As Long
    Dim jMax As Long
    Dim dw As Double
    Dim dM As Double
    Dim dOk As Double
    Dim dTotal As Double
    Dim dDimZ() As Double
    Dim dS() As Double
    Dim dZ() As Double
    Dim dZ2() As Double

    Randomize

    Set ARS = CreateObject("System.Collections.ArrayList")
    Set wkM = Sheets("明細")
    Set wkS = Sheets("最適計算")
    Set wkZ = Sheets("在庫")

    With wkM
        iw = .Cells(.Rows.Count, "A").End(xlUp).Row
        If 1 < iw Then
            .Rows("2:" & iw).Delete
        End If
        .Range("A1:E1").Value = Array("seihin", "使用在庫", "使用size", "使用残", "使用kazu")
    End With

    With wkS
        For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
            cw = .Cells(i, "A").Value
            If Not ARS.Contains(cw) Then
                ARS.Add cw
            End If
        Next i
        .Columns("D:E").ClearContents
        .Range("D1:E1").Value = Array("SIYOnagasa1", "SIYOkazu")
    End With

    For i = 0 To ARS.Count - 1
        cOK = ""
        dM = 99999
        dOk = 99999
        iOk = 999
        iCou = 0
        iMaxS = 0
        dTotal = 0

        '製品配列作成
        For j = 2 To wkS.Cells(wkS.Rows.Count, "A").End(xlUp).Row
            If ARS(i) = wkS.Cells(j, "A").Value Then
                For k = 1 To wkS.Cells(j, "B").Value
                    ReDim Preserve dS(iMaxS)
                    dS(iMaxS) = wkS.Cells(j, "C").Value
                    If dS(iMaxS) < dM Then
                        dM = dS(iMaxS)
                    End If
                    iMaxS = iMaxS + 1
                Next k
                dTotal = dTotal + wkS.Cells(j, "B").Value * wkS.Cells(j, "C").Value
            End If
        Next j

        jMax = 0
        ReDim dDimZ(1, 0)

        '在庫配列作成
        For j = 2 To wkZ.Cells(wkZ.Rows.Count, "A").End(xlUp).Row
            If ARS(i) = wkZ.Cells(j, "A").Value Then
                If dM <= wkZ.Cells(j, "C").Value Then
                    ReDim Preserve dDimZ(1, jMax)
                    dDimZ(0, jMax) = wkZ.Cells(j, "B").Value
                    dDimZ(1, jMax) = wkZ.Cells(j, "C").Value
                    If iMaxS < dDimZ(0, jMax) Then
                        dDimZ(0, jMax) = iMaxS
                    End If
                    iCou = iCou + dDimZ(0, jMax)
                    jMax = jMax + 1
                End If
            End If
        Next j

        '計算用在庫配列
        If 0 < iCou Then
            iw = 0
            ReDim dZ(iCou - 1)
            For j = 0 To jMax - 1
                For k = 1 To dDimZ(0, j)
                    dZ(iw) = dDimZ(1, j)
                    iw = iw + 1
                Next k
            Next j

            'ランダムに在庫選択
            For j = 0 To 999999
                dw = 0
                cw = String(iCou, "0")
                For k = 1 To iCou
                    If Rnd() * 2 < 1 Then
                        Mid(cw, k, 1) = "1"
                    End If
                Next k

                '製品合計<素材合計の候補
                iSu = 0
                For k = 0 To iw - 1
                    If Mid(cw, k + 1, 1) = "1" Then
                        ReDim Preserve dZ2(iSu)
                        dZ2(iSu) = dZ(k)
                        iSu = iSu + 1
                    End If
                Next k

                If 0 < iSu Then
                    ReDim iZ2(iSu - 1)

                    '切断可能かチェック
                    iFlag = 0
                    For k = 0 To UBound(dS)
                        For m = 0 To iSu - 1
                            If dS(k) < dZ2(m) Then
                                If LIMIT < dS(k) Then
                                    dZ2(m) = dZ2(m) - dS(k)
                                    iZ2(m) = 1
                                    Exit For
                                ElseIf dZ2(m) <= LIMIT Then
                                    dZ2(m) = dZ2(m) - dS(k)
                                    iZ2(m) = 1
                                    Exit For
                                End If
                            End If
                        Next m
                        If iSu <= m Then
                            iFlag = 1
                            Exit For
                        End If
                    Next k
                Else
                    iFlag = 1
                End If

                '切断可能だったので、最適候補と比較
                If iFlag = 0 Then
                    '使わなかった在庫候補を消す
                    For k = 0 To iSu - 1
                        If iZ2(k) = 0 Then
                            Mid(cw, k + 1, 1) = "0"
                        End If
                    Next k

                    dw = 0
                    For k = 0 To iSu - 1
                        dw = dw + dZ2(k)
                    Next k
                    If dw < dOk Then
                        iOk = iSu
                        cOK = cw
                        dOk = dw
                    End If
                End If
            Next j
        End If

        '結果表示
        For j = 2 To wkS.Cells(wkS.Rows.Count, "A").End(xlUp).Row
            If wkS.Cells(j, "A").Value = ARS(i) Then
                If cOK = "" Then
                    If iCou = 0 Then
                        wkS.Cells(j, "D").Value = "在庫なし"
                    Else
                        wkS.Cells(j, "D").Value = "切断不可"
                    End If
                Else
                    iw = 0
                    For k = 0 To iCou - 1
                        If Mid(cOK, k + 1, 1) = "1" Then
                            If wkS.Cells(j + iw, "D").Value = dZ(k) Then
                                wkS.Cells(j + iw, "E").Value = wkS.Cells(j + iw, "E").Value + 1
                            Else
                                If wkS.Cells(j + iw, "D").Value <> "" Then
                                    iw = iw + 1
                                End If
                                wkS.Cells(j + iw, "D").Value = dZ(k)
                                wkS.Cells(j + iw, "E").Value = 1
                            End If
                        End If
                    Next k
                End If
                Exit For
            End If
        Next j

        '明細表示
        With wkM
            iw = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
            iSu = 0
            For k = 0 To iCou - 1
                If Mid(cOK, k + 1, 1) = "1" Then
                    ReDim Preserve dZ2(iSu)
                    dZ2(iSu) = dZ(k)
                    .Cells(iw + iSu, "A").Value = ARS(i)
                    .Cells(iw + iSu, "B").Value = dZ(k)
                    .Cells(iw + iSu, "C").FormulaR1C1 = "=Sum(RC[3]:RC[101])"
                    .Cells(iw + iSu, "D").FormulaR1C1 = "=RC[-2]-RC[-1]"
                    .Cells(iw + iSu, "E").FormulaR1C1 = "=Count(RC[1]:RC[99])"
                    iSu = iSu + 1
                End If
            Next k

            For k = 0 To UBound(dS)
                For m = 0 To iSu - 1
                    If dS(k) < dZ2(m) Then
                        If LIMIT < dS(k) Then
                            dZ2(m) = dZ2(m) - dS(k)
                            .Cells(iw + m, "A").End(xlToRight).Offset(0, 1).Value = dS(k)
                            Exit For
                        ElseIf dZ2(m) <= LIMIT Then
                            dZ2(m) = dZ2(m) - dS(k)
                            .Cells(iw + m, "A").End(xlToRight).Offset(0, 1).Value = dS(k)
                            Exit For
                        End If
                    End If
                Next m
            Next k
        End With
    Next i

    Set ARS = Nothing
 End Sub
(???) 2016/04/08(金) 12:00

 (???)さん、勉強させていただいております。
 平日は時間がとれないので、本日、さわりの所だけ拝見することができました。
 なかなか難しい問題ということが改めてわかりました。
 ありがとうございました。

 --------------------
 以下、質問者さんの質問とは離れますので、申し訳ないですが、お許し願います。
 また、お急ぎの方はスキップ願います。

 (注:以下、余談です)
 先日、cutting stock問題について取り組んでいる方のサイトを紹介しました。
 そちらで私に対するコメントがありましたので、
 この場所をお借りしてお礼を申し上げ、
 また気づいた点を少しコメントさせていただきます。

 (1)
 たしかに、私のコメントは一般解があるように誤解されうる表現でした。
 もちろんそういうものがあるとは思っておりません。(特に修正は致しません)

 (2)
 2016.02.02の記事に関してですが、
 海外文献についての解釈が違うのではないでしょうか。
 材料はもともと8個という前提ですね、海外文献では。
 問題を拡張解釈して、歩留まりが99.96%になったと言っても、前提が違うと思います。

 (3)
 また、最新の2016.04.06の記事では、単にこの材料と製品のデータを借りただけだと
 思います。(材料は各材料が複数であっても良いという前提。)
 ただし、"回答者"の歩留まりが88.24%というのはどのように作られたのか不明でした。
 そんな低いものしか得られないはずは無いと思います。
 私もコードを書いて、単なるランダム実験をしてみましたが、
 差が544で歩留まり率は99.2%程度にはなりました。
 (99.96%はさすがとは思いましたが。)

(γ) 2016/04/10(日) 00:35


 質問者さんには無関係なコメントを続けて恐縮です。

 http://mathinfo.blog.fc2.com/blog-entry-185.html
 のvarumさんの言及にコメントさせて頂きます。

 あちらのサイトで発言せよ、とお叱りを受ける直前かと思いますが、
 あちらは個人情報の一部を求められているので(セキュリティ確保のため不可避と承知はしています)、
 ついこちらで書いてしまいます。お許し願います。

 種類を言っているのか、個数も含めてなのかという件ですが、
 種類を示すなら、同じ長さの材料が複数列挙されているProblem1 の L は、
 別の書き方になるのかなあ、と思ったまでです。
 問題の設定として、材料と製品の数 N,n を制約としてあげていますしね。
 Problem2は使用する材料の種類もできるだけ節約するということを目指したheuristicな方法を
 提示されているのではないか、というのが素人の私の印象でした。 

 (???)さんのtest4を使用した歩留まり率である旨、承知しました。
 私はまだそこまで拝見していなかったのです。
 最初のtest()だけ拝見したところです。
 私の書いたのはその後、399(歩留まり99.4%)というのがありました。

 (???)さんのは質問者の意向に忠実に材料を大きい順に使っているのですが、
 たぶんその順序もランダムにしたほうが最適解に近づけるのだとは思います。
 varumさんの手法と少し細かいところで前提が違うのかもしれないと思いました。

 いずれにしても、貴重なご意見をいただきありがとうございました。

(γ) 2016/04/10(日) 22:26


総当たりの改良版なぞ。

前の総当たり版(ランダム版もですが)では、在庫の順番違いも含めてチェックしていました。(ビット判定)
しかし、同じ長さの在庫ならば、順番はどうでも良いわけで、1つ目を何個、2つ目を何個…、という考えに変えることで、組合せを減らしています。

切断判定は、相変わらず大きいものから選ぶのみであり、最適ではないという結果は変わりませんが、速度向上が大きいかと思います。
(この切断判定が単純なおかげで、結果出力が簡単(同じ切断判定をするだけ)だったりします)

 Sub test7()
    Const LIMIT = 3000
    Dim ARS As Object
    Dim wkM As Worksheet
    Dim wkS As Worksheet
    Dim wkZ As Worksheet
    Dim cw As String
    Dim cOK As String
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim m As Long
    Dim iw As Long
    Dim iOk As Long
    Dim iSu As Long
    Dim iCou As Long
    Dim iZ2() As Long
    Dim iFlag As Long
    Dim iMaxS As Long
    Dim jMax As Long
    Dim iL() As Long
    Dim iLMax As Long
    Dim dw As Double
    Dim dM As Double
    Dim dOk As Double
    Dim dTotal As Double
    Dim dDimZ() As Double
    Dim dS() As Double
    Dim dZ() As Double
    Dim dZ2() As Double

    Set ARS = CreateObject("System.Collections.ArrayList")
    Set wkM = Sheets("明細")
    Set wkS = Sheets("最適計算")
    Set wkZ = Sheets("在庫")

    With wkM
        iw = .Cells(.Rows.Count, "A").End(xlUp).Row
        If 1 < iw Then
            .Rows("2:" & iw).Delete
        End If
        .Range("A1:E1").Value = Array("seihin", "使用在庫", "使用size", "使用残", "使用kazu")
    End With

    With wkS
        For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
            cw = .Cells(i, "A").Value
            If Not ARS.Contains(cw) Then
                ARS.Add cw
            End If
        Next i
        .Columns("D:E").ClearContents
        .Range("D1:E1").Value = Array("SIYOnagasa1", "SIYOkazu")
    End With

    For i = 0 To ARS.Count - 1
        cOK = ""
        dM = 99999
        dOk = 99999
        iOk = 999
        iCou = 0
        iMaxS = 0
        dTotal = 0

        '製品配列作成
        For j = 2 To wkS.Cells(wkS.Rows.Count, "A").End(xlUp).Row
            If ARS(i) = wkS.Cells(j, "A").Value Then
                For k = 1 To wkS.Cells(j, "B").Value
                    ReDim Preserve dS(iMaxS)
                    dS(iMaxS) = wkS.Cells(j, "C").Value
                    If dS(iMaxS) < dM Then
                        dM = dS(iMaxS)
                    End If
                    iMaxS = iMaxS + 1
                Next k
                dTotal = dTotal + wkS.Cells(j, "B").Value * wkS.Cells(j, "C").Value
            End If
        Next j

        jMax = 0
        ReDim dDimZ(1, 0)

        '在庫配列作成
        For j = 2 To wkZ.Cells(wkZ.Rows.Count, "A").End(xlUp).Row
            If ARS(i) = wkZ.Cells(j, "A").Value Then
                If dM <= wkZ.Cells(j, "C").Value Then
                    If 0 < wkZ.Cells(j, "B").Value Then
                        ReDim Preserve dDimZ(1, jMax)
                        dDimZ(0, jMax) = wkZ.Cells(j, "B").Value
                        dDimZ(1, jMax) = wkZ.Cells(j, "C").Value
                        If iMaxS < dDimZ(0, jMax) Then
                            dDimZ(0, jMax) = iMaxS
                        End If
                        iCou = iCou + dDimZ(0, jMax)
                        jMax = jMax + 1
                    End If
                End If
            End If
        Next j

        '計算用在庫配列
        If 0 < iCou Then
            iw = 0
            ReDim dZ(iCou - 1)
            For j = 0 To jMax - 1
                For k = 1 To dDimZ(0, j)
                    dZ(iw) = dDimZ(1, j)
                    iw = iw + 1
                Next k
            Next j

            '総当たり在庫選択
            iLMax = 1
            ReDim iL(jMax - 1)
            For j = 0 To jMax - 1
                iLMax = iLMax * (dDimZ(0, j) + 1)
            Next j

            For j = 1 To iLMax - 1
                iL(0) = iL(0) + 1
                For k = 0 To jMax - 1
                    If dDimZ(0, k) < iL(k) Then
                        iL(k) = 0
                        iL(k + 1) = iL(k + 1) + 1
                    End If
                Next k

                cw = String(iCou, "0")
                m = 0
                For k = 0 To jMax - 1
                    Mid(cw, m + 1, iL(k)) = String(iL(k), "1")
                    m = m + dDimZ(0, k)
                Next k

                '製品合計<素材合計の候補
                iSu = 0
                For k = 0 To iw - 1
                    If Mid(cw, k + 1, 1) = "1" Then
                        ReDim Preserve dZ2(iSu)
                        dZ2(iSu) = dZ(k)
                        iSu = iSu + 1
                    End If
                Next k

                If 0 < iSu Then
                    ReDim iZ2(iSu - 1)

                    '切断可能かチェック
                    iFlag = 0
                    For k = 0 To UBound(dS)
                        For m = 0 To iSu - 1
                            If dS(k) < dZ2(m) Then
                                If LIMIT < dS(k) Then
                                    dZ2(m) = dZ2(m) - dS(k)
                                    iZ2(m) = 1
                                    Exit For
                                ElseIf dZ2(m) <= LIMIT Then
                                    dZ2(m) = dZ2(m) - dS(k)
                                    iZ2(m) = 1
                                    Exit For
                                End If
                            End If
                        Next m
                        If iSu <= m Then
                            iFlag = 1
                            Exit For
                        End If
                    Next k
                Else
                    iFlag = 1
                End If

                '切断可能だったので、最適候補と比較
                If iFlag = 0 Then
                    '使わなかった在庫候補を消す
                    For k = 0 To iSu - 1
                        If iZ2(k) = 0 Then
                            Mid(cw, k + 1, 1) = "0"
                        End If
                    Next k

                    dw = 0
                    For k = 0 To iSu - 1
                        dw = dw + dZ2(k)
                    Next k
                    If dw < dOk Then
                        iOk = iSu
                        cOK = cw
                        dOk = dw
                    End If
                End If
            Next j
        End If

        '結果表示
        For j = 2 To wkS.Cells(wkS.Rows.Count, "A").End(xlUp).Row
            If wkS.Cells(j, "A").Value = ARS(i) Then
                If cOK = "" Then
                    If iCou = 0 Then
                        wkS.Cells(j, "D").Value = "在庫なし"
                    Else
                        wkS.Cells(j, "D").Value = "切断不可"
                    End If
                Else
                    iw = 0
                    For k = 0 To iCou - 1
                        If Mid(cOK, k + 1, 1) = "1" Then
                            If wkS.Cells(j + iw, "D").Value = dZ(k) Then
                                wkS.Cells(j + iw, "E").Value = wkS.Cells(j + iw, "E").Value + 1
                            Else
                                If wkS.Cells(j + iw, "D").Value <> "" Then
                                    iw = iw + 1
                                End If
                                wkS.Cells(j + iw, "D").Value = dZ(k)
                                wkS.Cells(j + iw, "E").Value = 1
                            End If
                        End If
                    Next k
                End If
                Exit For
            End If
        Next j

        '明細表示
        With wkM
            iw = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
            iSu = 0
            For k = 0 To iCou - 1
                If Mid(cOK, k + 1, 1) = "1" Then
                    ReDim Preserve dZ2(iSu)
                    dZ2(iSu) = dZ(k)
                    .Cells(iw + iSu, "A").Value = ARS(i)
                    .Cells(iw + iSu, "B").Value = dZ(k)
                    .Cells(iw + iSu, "C").FormulaR1C1 = "=Sum(RC[3]:RC[101])"
                    .Cells(iw + iSu, "D").FormulaR1C1 = "=RC[-2]-RC[-1]"
                    .Cells(iw + iSu, "E").FormulaR1C1 = "=Count(RC[1]:RC[99])"
                    iSu = iSu + 1
                End If
            Next k

            For k = 0 To UBound(dS)
                For m = 0 To iSu - 1
                    If dS(k) < dZ2(m) Then
                        If LIMIT < dS(k) Then
                            dZ2(m) = dZ2(m) - dS(k)
                            .Cells(iw + m, "A").End(xlToRight).Offset(0, 1).Value = dS(k)
                            Exit For
                        ElseIf dZ2(m) <= LIMIT Then
                            dZ2(m) = dZ2(m) - dS(k)
                            .Cells(iw + m, "A").End(xlToRight).Offset(0, 1).Value = dS(k)
                            Exit For
                        End If
                    End If
                Next m
            Next k
        End With
    Next i

    Set ARS = Nothing
 End Sub

(13:31 在庫を選ばないケースが抜けていたので、修正)
(???) 2016/04/11(月) 12:31


(???)さんありがとうございます。
理想的な結果になりました。

中身が私には高度な為、このソースを元に勉強させて頂きます。
重ね重ね修正頂き感謝申し上げます。

(mana) 2016/04/12(火) 14:50


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.