[[20111114163123]]　『Excelの先入先出の方法★その３』（らんきち）　ページの最後に飛ぶ

『Excelの先入先出の方法★その３』（らんきち）

[[20111110145634]]

の続きです。

 ＞在庫の中には引当済みで、未出庫

 この「引当済みで未出庫」がN列とQ列になります。

 前日の「倉庫現在庫」を当日に「前日在庫」に移した時にN列とQ列も手入力で移しますので、
 引当可能在庫に「前日在庫」からN列とQ列が差し引かれた数字が入ることになります。

 なんかわかりにくくてすみません…

 ということは、Ｒ列以降の、その他出荷指示（？　PM でも PM2 でもない出荷指示）は、
「必ず、その日の内に出荷される。積み残されることはない」というルールなんだね？
ということなら、了解。

 (ぶらっと)

 ＞必ず、その日の内に出荷される。積み残されることはない

 はい、そうなります。

（らんきち）

ぶらっと様

 すみません、引き続き動作確認などしていたのですが、いつの間にか「Menu」シートのコマンドボタンを押して
 出荷指示のユーザーフォームを呼び出そうとすると、標準モジュール1

 Sub 出荷指示()
    If IsFormLoaded Then Exit Sub
    With UserForm1
        .Tag = "A" '出荷指図
        .Show vbModeless
    End With
 End Sub

    With UserForm1

 のところで「型が一致しません」というエラーが出るようになりました。

 昨日やったのは商品一覧に商品を登録するユーザーフォームを作ったことです。

 UserForm1 のコードを試しに全部コメントブロックにしたら呼び出しだけはできました。

 別のユーザーフォームを作ったのが悪かったのか、在庫シートのレイアウトを変えたのがいけなかったのか…

 どの時点でエラーが出るようになったのかはっきりしません。

 もうちょっと試してみます。

（らんきち）

 上のレスについては、いったん今回アップするコードで、もう一度試してみて。

 まとまって本件に取り組み時間がとれなかったので、随分、間があいてしまい恐縮。
とりあえず書き上げたのでコードをアップするけど・・・
ちょっと悩んだ。コードそのものが仕様の二転三転でごちゃついていることもあるけど
そもそもが、データ処理にはふさわしいと思えないような（失礼）現行の在庫シートのレイアウトと
これも、あまり「システム的」とはいえないような人間系の処理実態を反映させているので
データの持ち方が、ちょっと複雑怪奇。プログラム使用書もない状態で、今後、これを、そちらで
メンテしくれるかどうか・・・？　でも、まぁ、がんばってもらうことにして。

 前触れで。
１．新しく　「出荷引当実行」プロシジャを準備した。menuシートにボタンを追加して、そのボタンに
　　このプロシジャをマクロ登録してください。
２．出荷指示書作成「兼」出荷引当　機能は、最終的には消した。なので、連続して作業する場合は
　　menuでボタンを選びなおしてね。
３．Module1 の先頭で　商品一覧シート、在庫シートの列の規定をしている。
　　ここをもう一度、よく確認願う。
　　なお、ここを変更すれば、コード変更なしで、レイアウト変更に対応できる。
４．この列規定の意味するところは
　　プログラムでは、この項目「しか」相手にしていない。（在庫数量関係はいっさい参照していない）
５．出荷指図書作成では引当可能在庫を参照しているが、引当実行では、ちょっと手を抜いてチェックせず
　　出荷指示書にある数量をそのまま使っている。
６．引当可能数量は、そちらの計算式で、「常に正しく」値がセットされているということが大前提。
　　プログラムではいっさい、ここを変更していない。
７．出荷指示書作成の元ねたは出荷依頼データ、出荷引当実行の元ねたはできあがっている指示書シート。
８．いずれも、処理の最後にこのブックを自動保存している。ここが、結構、思いようで実際には処理が終了
　　しているけど、終了メッセージがでるまで、時間がかかるかもしれない。
９．なお、用意した機能は、基本的に「新規作成・登録」。実際の業務では「取消」や「訂正」も
　　必要になると思うけど、以下のように運用してほしい。
　　１）出荷指示書
　　　　取消　シートを削除する。
　　　　訂正　新たに新規作成して上書きするか、あるいはシートに直接手入力で変更。
　　２）引当
　　　　まず、在庫シートに直接手入力で変更（あるいは列削除）することが考えられる。
　　　　同じ引当をするとメッセージがでて、上書きも可能になっているので、これを利用して
　　　　指示書側を訂正しておいて引当実行ということも可能。（取消の場合は指示書数量をゼロにしておく）

 (Module1)

 '標準モジュール Module1

 Option Explicit

 Enum func
    fnOpen
    fnInitial
    fnGet
    fnGetList
    fnPut
    fnRegister
    fnAllocate
    fnSort
    fnClose
 End Enum

 'シート名規定
 Public Const shn商品一覧 As String = "商品一覧"
 Public Const shn出荷依頼 As String = "Sheet2"
 Public Const tpl出荷指示 As String = "Sheet3"
 '商品一覧列規定
 Public Const IDCol As String = "A"   '商品ID列
 Public Const ABBRCol As String = "C" '商品略称列
 '在庫シート規定
 Public Const 商品IDCol As String = "A"
 Public Const 履歴開始Col As String = "R"
 Public Const 履歴終了Col As String = "AR"
 Public Const 指示PMCol As String = "O"
 Public Const 指示PM2Col As String = "P"
 Public Const 引当可能Col As String = "I"
 Public Const 保留Col As String = "C"
 Public Const 賞味期限Col As String = "D"
 Public Const ロットCol As String = "F"

 Sub 出荷指示()
    If IsFormLoaded Then Exit Sub
    With UserForm1
        .Tag = "A" '出荷指図
        .Show vbModeless
    End With
 End Sub

 Sub 引当更新()
    If IsFormLoaded Then Exit Sub
    With UserForm1
        .Tag = "B" '引当更新
        .Show vbModeless
    End With
 End Sub

 (Module2)

 '標準モジュール Module2

 Option Explicit

 Function io商品(fc As func, Optional cd As String, Optional comAbbr As String, _
                Optional qty As Long, Optional dldate As Date, _
                Optional lot As String, Optional syomi As Date) As Variant
    Static dicM As Object
    Static dicH As Object
    Dim first As Boolean
    Dim c As Range
    Dim sh As Worksheet
    Dim comID As String
    Dim dKey As Variant
    Dim reqQty As Long
    Dim dDate As Date
    Dim dQty As Long
    Dim dLot As String
    Dim v() As Variant
    Dim setQty As Long
    Dim wk As Variant
    Dim i As Long
    Dim d保留 As Variant
    Dim d賞味期限 As Variant
    Dim dロット As Variant
    Dim d引当可能 As Variant
    Dim dm As Long
    Dim w As Variant
    Dim x As Long
    Dim myCol As Long
    Dim myflag As Boolean
    Dim minQ As Long
    Dim maxQ As Long

    Select Case fc

        Case fnOpen
            Set dicM = CreateObject("Scripting.Dictionary")
            Set dicH = CreateObject("Scripting.Dictionary")
            For Each sh In Worksheets
                If Left(sh.Name, 2) = "在庫" Then
                    comAbbr = Mid(sh.Name, 3)
                    Set dicM(comAbbr) = CreateObject("Scripting.Dictionary")
                    Set dicH(comAbbr) = CreateObject("Scripting.Dictionary")
                    For Each c In sh.Range(商品IDCol & "6", sh.Range(商品IDCol & sh.Rows.Count).End(xlUp))
                        i = c.Row
                        With sh
                            d保留 = .Cells(i, 保留Col).Value
                            d賞味期限 = .Cells(i, 賞味期限Col).Value
                            dロット = .Cells(i, ロットCol).Value
                            d引当可能 = .Cells(i, 引当可能Col).Value
                        End With

                        If Len(d保留) = 0 And Len(d賞味期限) > 0 Then '保留マーク空白/賞味期限あり
                            dicM(comAbbr)(dicM(comAbbr).Count + 1) = Array(d賞味期限, dロット, d引当可能)
                            dicH(comAbbr)(CDbl(d賞味期限) & vbTab & dロット) = c.Row
                        End If
                    Next
                End If
            Next

        Case fnGet
            If Not dicM.exists(comAbbr) Then Exit Function
            first = True
            reqQty = qty
            comID = "登録なし"
            wk = Application.Match(comAbbr, Sheets(shn商品一覧).Columns(ABBRCol), 0)
            If IsNumeric(wk) Then
                comID = Sheets(shn商品一覧).Cells(wk, IDCol).Value
            End If
            For Each dKey In dicM(comAbbr)
                dDate = dicM(comAbbr)(dKey)(0)
                dLot = dicM(comAbbr)(dKey)(1)
                dQty = dicM(comAbbr)(dKey)(2)
                wk = dicM(comAbbr)(dKey)
                If dldate <= dDate And dQty > 0 Then
                    If dQty >= reqQty Then
                        setQty = reqQty
                        wk(2) = wk(2) - setQty
                    Else
                        setQty = dQty
                        wk(2) = 0
                    End If
                    reqQty = reqQty - setQty
                    dicM(comAbbr)(dKey) = wk
                    If first Then
                        ReDim v(1 To 7, 1 To 1)
                        first = False
                    Else
                        ReDim Preserve v(1 To UBound(v, 1), 1 To UBound(v, 2) + 1)
                        wk(1) = 0
                    End If
                    v(1, UBound(v, 2)) = cd
                    v(2, UBound(v, 2)) = comAbbr
                    v(3, UBound(v, 2)) = dDate
                    v(4, UBound(v, 2)) = dLot
                    v(5, UBound(v, 2)) = setQty
                    v(6, UBound(v, 2)) = dldate
                    v(7, UBound(v, 2)) = comID
                End If
                If dicM(comAbbr)(dKey)(1) = 0 Then dicM(comAbbr).Remove dKey
                If reqQty = 0 Then Exit For
            Next
            If Not first Then
                v = WorksheetFunction.Transpose(v)
                dm = getDimension(v)
                If dm = 1 Then   '１次元配列なら１行の２次元に
                    ReDim w(1 To 1, 1 To UBound(v))
                    For x = 1 To UBound(v)
                        w(1, x) = v(x)
                    Next
                    v = w
                End If
                io商品 = v
            End If

        Case fnSort
            For Each sh In Worksheets
                If Left(sh.Name, 2) = "在庫" Then
                    With sh.Range(商品IDCol & "6", sh.Range(商品IDCol & sh.Rows.Count).End(xlUp)).EntireRow
                        .Sort Key1:=.Columns(商品IDCol), Order1:=xlAscending, _
                              Key2:=.Columns(賞味期限Col), Order2:=xlAscending, Header:=xlNo
                    End With
                End If
            Next

        Case fnRegister

            myflag = False

            With Sheets("在庫" & comAbbr)
                If cd = "PM" Or cd = "PM2" Then
                    If cd = "PM" Then
                        myCol = Columns(指示PMCol).Column
                    ElseIf cd = "PM2" Then
                        myCol = Columns(指示PM2Col).Column
                    End If
                    minQ = WorksheetFunction.Min(.Cells(6, myCol).Resize(dicH(comAbbr).Count))
                    maxQ = WorksheetFunction.Max(.Cells(6, myCol).Resize(dicH(comAbbr).Count))

                    If minQ <> 0 Or maxQ <> 0 Then
                        If MsgBox(comAbbr & "-" & cd & "はすでに引当済みです" & vbLf & _
                                "上書きしますか？", vbYesNo) = vbYes Then myflag = True
                    Else
                        myflag = True
                    End If
                Else
                    For myCol = Columns(履歴開始Col).Column To Columns(履歴終了Col).Column
                        If Len(.Cells(4, myCol)) = 0 Then
                            myflag = True
                            Exit For
                        End If
                        If .Cells(4, myCol).Value = dldate And .Cells(5, myCol).Value = cd Then
                            If MsgBox(comAbbr & "-" & cd & "-" & dldate & "はすでに引当済みです" & vbLf & _
                                "上書きしますか？", vbYesNo) = vbYes Then myflag = True
                            Exit For
                        End If
                    Next
                End If

                If myflag Then
                    .Cells(6, myCol).Resize(dicH(comAbbr).Count).ClearContents
                    If cd <> "PM" Or cd <> "PM2" Then .Cells(4, myCol).Value = dldate
                    .Cells(5, myCol).Value = cd
                End If

                io商品 = myflag

            End With

        Case fnAllocate
            '在庫シート
            myflag = False
            With Sheets("在庫" & comAbbr)
                If cd = "PM" Or cd = "PM2" Then
                    myflag = True
                    If cd = "PM" Then
                        myCol = Columns(指示PMCol).Column
                    ElseIf cd = "PM2" Then
                        myCol = Columns(指示PM2Col).Column
                    End If
                Else
                    For myCol = Columns(履歴開始Col).Column To Columns(履歴終了Col).Column
                        If .Cells(4, myCol).Value = dldate And .Cells(5, myCol).Value = cd Then
                            myflag = True
                            Exit For
                        End If
                    Next
                End If

                If myflag Then .Cells(dicH(comAbbr)(CDbl(syomi) & vbTab & lot), myCol).Value = _
                        .Cells(dicH(comAbbr)(CDbl(syomi) & vbTab & lot), myCol).Value + qty
                io商品 = myflag
            End With

        Case fnClose
            If Not dicM Is Nothing Then
                dicM.RemoveAll
                Set dicM = Nothing
            End If
            If Not dicH Is Nothing Then
                dicH.RemoveAll
                Set dicH = Nothing
            End If

    End Select

 End Function

 Function IsFormLoaded() As Boolean
    If UserForms.Count > 0 Then
        MsgBox "呼び出し中のフォームを閉じてから処理してください"
        IsFormLoaded = True
    End If
 End Function

 Function get出荷指示シート名(cd As Variant, dldate As Variant) As String
    get出荷指示シート名 = "出荷指示_" & cd & "_" & Format(CDate(dldate), "yy-mm-dd")
 End Function

 Private Function getDimension(v) As Long
    Dim i As Long
    Dim wk As Long

    On Error Resume Next
    Do
        i = i + 1
        wk = UBound(v, i)
    Loop While Err.Number = 0
    On Error GoTo 0
    getDimension = i - 1

 End Function

 (Module3)

 '標準モジュール　Module3

 Option Explicit

 Sub 出荷指示書作成(cds As Variant, dls As Variant)
    Dim i As Long
    Dim buf As Variant
    Dim c As Range
    Dim wk As Variant
    Dim cd As String
    Dim dl As String
    Dim k As Long

    For Each wk In cds
        k = k + 1
        cd = wk
        dl = dls(k)
        If make出荷指示書(fnInitial, cd, dl) Then

            With Sheets(shn出荷依頼)  '出荷依頼データ
                For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
                    If c.Value = cd Then
                        '                出荷コード   商品ABBR            数量               出荷日
                        buf = io商品(fnGet, cd, c.Offset(, 1).Value, c.Offset(, 2).Value, c.Offset(, 3).Value)
                        If IsArray(buf) Then Call make出荷指示書(fnPut, buf)
                    End If
                Next
                make出荷指示書 fnPut, False   '最終データの小計処理
            End With

        End If

    Next

 End Sub

 Function make出荷指示書(fc As func, Optional v As Variant, Optional vv As Variant) As Boolean
    Static shn As String
    Static dicO As Object
    Static first As Boolean
    Static oldCom As String
    Static newCom As String
    Static comQty As Long
    Static comLine As Long
    Dim cd As String
    Dim s As String
    Dim w As Variant
    Dim i As Long
    Dim c As Range
    Dim q As Long
    Dim l As Long

    Select Case fc

        Case fnOpen
            Set dicO = CreateObject("Scripting.Dictionary")
            With Sheets(shn出荷依頼)  '出荷依頼データ
                For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
                    cd = c.Value
                    s = c.Offset(, 1).Value & "(" & Format(c.Offset(, 2).Value, "#,##0") & ")"
                    If dicO.exists(cd) Then
                        If dicO(cd)(1) <> c.Offset(, 3).Value2 Then
                            MsgBox "出荷コード:" & cd & "の出荷日は全て同じにしてください"
                            Exit Function
                        End If
                        w = dicO(cd)
                        w(2) = w(2) & " " & s
                        dicO(cd) = w
                    Else
                        dicO(cd) = Array(cd, c.Offset(, 3).Value2, s)
                    End If
                 Next
            End With

        Case fnGetList

            v = dicO.items
            v = Application.Transpose(Application.Transpose(v))
            If dicO.Count = 1 Then
                ReDim w(1 To 1, 1 To 3)
                    w(1, 1) = v(1)
                    w(1, 2) = CDate(v(2))
                    w(1, 3) = v(3)
                    v = w
            Else
                For i = LBound(v, 1) To UBound(v, 1)
                    v(i, 2) = CDate(v(i, 2))
                Next
            End If

        Case fnInitial

            shn = get出荷指示シート名(v, vv)
            If IsObject(Evaluate("'" & shn & "'!A1")) Then
                If MsgBox(shn & "がすでに存在します。削除して置き換えていいですか？", vbYesNo) = vbNo Then Exit Function
                Application.DisplayAlerts = False
                Sheets(shn).Delete
                Application.DisplayAlerts = True
            End If
            Sheets(tpl出荷指示).Copy After:=Sheets(Sheets.Count)
            With Sheets(Sheets.Count)
                .Visible = True
                .Name = shn
                .Unprotect
            End With
            first = True
            comQty = 0
            comLine = 0

        Case fnPut

            With Sheets(shn)
                With .Range("A" & .Rows.Count).End(xlUp).Offset(1)
                    If IsArray(v) Then
                        newCom = v(1, 2)
                        q = WorksheetFunction.Sum(WorksheetFunction.Index(v, 0, 5))
                        l = UBound(v, 1)

                        If first Then
                            oldCom = newCom
                            first = False
                        End If

                    End If

                    If Not IsArray(v) Or oldCom <> newCom Then
                        If comLine = 1 Then
                            .Value = " " 'スペース　商品ブレーク　ただし１行ゆえ小計なし
                        Else
                            .Value = " " 'スペース　小計行
                            .Offset(, 3).Value = "小計"
                            .Offset(, 4) = comQty
                        End If
                        comQty = 0
                        comLine = 0
                    End If

                    If Not IsArray(v) Then Exit Function

                    comQty = comQty + q
                    comLine = comLine + l
                    oldCom = newCom

                End With

                With .Range("A" & .Rows.Count).End(xlUp).Offset(1)
                    .Resize(UBound(v, 1), UBound(v, 2)).Value = v
                End With
            End With

        Case fnClose

            Set dicO = Nothing

    End Select

    make出荷指示書 = True

 End Function

 (Module4)

 Option Explicit

 '標準モジュール　Module4

 Sub 出荷引当実行(dlSheets As Variant)
    Dim i As Long
    Dim ans As Variant
    Dim c As Range
    Dim wk As Variant
    Dim k As Long
    Dim shn As String
    Dim cd As String
    Dim dl As Date
    Dim syomi As Date
    Dim qty As Long
    Dim lot As String
    Dim comAbbr As String
    Dim dicA As Object
    Dim aKey As Variant
    Dim sKey As Variant

    Set dicA = CreateObject("Scripting.Dictionary")
    '引当必要データの商品別格納
    For Each wk In dlSheets
        k = k + 1
        shn = wk
        If Not IsObject(Evaluate("'" & shn & "'!A1")) Then
            MsgBox shn & "シートがありません。処理をスキップします"
        Else
            With Sheets(shn)  '出荷依頼データ
                For Each c In .Range("B2", .Range("B" & Rows.Count).End(xlUp))
                    If Len(Trim(c.Value)) > 0 Then
                        comAbbr = c.Value
                        i = c.Row
                        cd = .Cells(i, "A").Value
                        syomi = .Cells(i, "C").Value
                        lot = .Cells(i, "D").Value
                        qty = .Cells(i, "E").Value
                        dl = .Cells(i, "F").Value

                        aKey = comAbbr & vbTab & cd & vbTab & CDbl(dl)

                        If Not dicA.exists(aKey) Then Set dicA(aKey) = _
                                            CreateObject("Scripting.Dictionary")
                        dicA(aKey)(dicA(aKey).Count + 1) = _
                                        Array(syomi, lot, qty)
                    End If
                Next
            End With
        End If
    Next
    '引当処理開始
    For Each aKey In dicA

        wk = Split(aKey, vbTab)
        comAbbr = wk(0)
        cd = wk(1)
        dl = CDate(wk(2))

        ans = io商品(fnRegister, cd, comAbbr:=comAbbr, dldate:=dl)

        If ans Then

            For Each sKey In dicA(aKey)
                wk = dicA(aKey)(sKey)
                syomi = CDate(wk(0))
                lot = wk(1)
                qty = wk(2)
                io商品 fnAllocate, cd, comAbbr, qty, dl, lot, syomi
            Next

        End If
    Next

    dicA.RemoveAll
    Set dicA = Nothing

 End Sub

 Function make引当更新データ(fc As func, Optional v As Variant) As Boolean
    Dim sh As Worksheet
    Dim k As Long

    Select Case fc

        Case fnOpen
            'Nop

        Case fnGetList

            ReDim v(1 To Worksheets.Count)
            For Each sh In Worksheets
                If Left(sh.Name, 5) = "出荷指示_" Then
                    k = k + 1
                    v(k) = sh.Name
                End If
            Next
            ReDim Preserve v(1 To k)

        Case fnClose
            'Nop

    End Select

    make引当更新データ = True

 End Function

 (ユーザーフォーム)

 'ユーザーフォームモジュール

 Option Explicit

Private Sub UserForm_Activate()

    Dim k As Long
    Dim sh As Worksheet
    Dim dic As Object
    Dim c As Range
    Dim v As Variant
    Dim i As Long
    Call io商品(fnOpen)
    Select Case Me.Tag
        Case "A"
            If Not make出荷指示書(fnOpen) Then Unload Me
            Me.Caption = "出荷指示書作成（指示書を作成する出荷コードを選んでください）"
            Call make出荷指示書(fnGetList, v)
            ListBox1.ColumnCount = 3
        Case "B"
            Call make引当更新データ(fnOpen)
            Me.Caption = "引当更新（引当可能在庫の更新を行います。対象の出荷データを選んでください）"
            Call make引当更新データ(fnGetList, v)
            ListBox1.ColumnCount = 1
    End Select
    ListBox1.List = v

    '以下はユーザーフォームのプロパティで設定すればコードは不要
    ListBox1.MultiSelect = fmMultiSelectExtended
    CommandButton1.Caption = "実行"
    CommandButton2.Caption = "全て選択"
    CommandButton3.Caption = "全て解除"

End Sub

 Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Call io商品(fnClose)
    If Me.Tag = "A" Then
        Call make出荷指示書(fnClose)
    Else
        Call make引当更新データ(fnClose)
    End If
 End Sub

 Private Sub CommandButton1_Click()
    Dim v() As String
    Dim w() As String
    Dim i As Long
    Dim k As Long
    Dim ans As Long
    Dim s As String

    With ListBox1
        ReDim v(1 To .ListCount)
        ReDim w(1 To .ListCount)
        For i = 0 To .ListCount - 1
            If .Selected(i) Then
                k = k + 1
                v(k) = .List(i)
                If Me.Tag = "A" Then w(k) = .List(i, 1)
            End If
        Next
        If k = 0 Then
            MsgBox "出荷データが選択されていません"
            Exit Sub
        Else
            CommandButton1.Enabled = False
            ReDim Preserve v(1 To k)
            If Me.Tag = "A" Then
                ReDim Preserve w(1 To k)
                s = "出荷指示書作成"
                Call 出荷指示書作成(v, w)
            Else
                s = "引当更新"
                Call 出荷引当実行(v)
            End If
            CommandButton1.Enabled = True

            With ListBox1
                For i = 0 To .ListCount - 1
                    .Selected(i) = False
                Next
            End With

        End If
    End With

    ThisWorkbook.Save
    MsgBox s & "処理が終了しました"

 End Sub

 Private Sub CommandButton2_Click()
    SelectAll True
 End Sub

 Private Sub CommandButton3_Click()
    SelectAll False
 End Sub

 Private Sub SelectAll(flag As Boolean)
    Dim i As Long
    With ListBox1
        For i = 0 To .ListCount - 1
            .Selected(i) = flag
        Next
    End With
 End Sub

 (ぶらっと)

ぶらっと様ありがとうございます。

 早速テストしてみました。

 しかしユーザーフォームを表示させる時点で二つのエラーが出ます。

 まずシート上のコマンドボタンを押してユーザーフォームを呼び出そうとすると、フォームは立ち上がりますが

 「実行時エラー'13'型が一致しません」

 というエラーが出ます。

　make出荷指示書の

                For i = LBound(v, 1) To UBound(v, 1)
                    v(i, 2) = CDate(v(i, 2))　　　　　←ここが黄色く反転します
                Next

 さらに一旦デバッグを終了して再度ワークシートのコマンドボタンを押してユーザーフォームを呼び出そうとすると

 「実行時エラー'440'オートメーションエラーです」

 というのが出ます。

 オートメーションエラーについて検索して、複数のユーザーフォームを使用している時に出る可能性が…という記事があったので
 一旦バックアップを取った上他のユーザーフォームを削除し、ブックを閉じて再度開いて実行しようとしてもやはり同じエラーになります。

 モジュール2の

 Function IsFormLoaded() As Boolean
    If UserForms.Count > 0 Then　　　←ここが黄色く反転します
        MsgBox "呼び出し中のフォームを閉じてから処理してください"
        IsFormLoaded = True
    End If
 End Function

 （他にオートメーションエラーではExcel2003と2007の互換性の関係という記事も見かけました。）

 いきなりエラー報告ですみません…

（らんきち）

 その追加したユーザーフォームが気になっている。
・そのフォームは、このマクロブックにあるのかな？
・もしそうだとして、そのユーザーフォームの名前は？
・で、実行時、そのユーザーフォームは呼び出されていた？それとも、呼び出されていない？

 らんきちさんの環境はwin7+xl2007 だよね。
一応、先ほどアップしたコードは XP+2003、Win7+2010 では稼動確認してあるんだけど？

 おそらくは、ユーザーフォーム（そちらで追加したものも含め）の問題ではなく
For i = LBound(v, 1) To UBound(v, 1)
    v(i, 2) = CDate(v(i, 2))　　　　　←ここが黄色く反転します
Next

 ここのところのエラーが、後々を引きずっているんだと推測する。
こちらでも確認してみるけど、Module1の列規定と、そちらの実際のシートのレイアウトは
合致している？

 (ぶらっと)

 >v(i, 2) = CDate(v(i, 2))　　　　　←ここが黄色く反転します

 ここは、出荷依頼データ（Sheet2)のD列の値を処理しているところ。
日付型で入力されているという前提なんだけど、大丈夫？

 それと、Module1のシート名規定に　 Public Const shnMenu As String = "menu"　を追加して、
ユーザーフォームモジュールの  MsgBox s & "処理が終了しました"　の前に　Sheets(shnMenu).Select　をいれておこう。
障害とは関係ないけど、終了したらメニューにもどったほうが操作しやすいと思うので。
もちろん、シート名は、仮に "menu"　としてあるけど、そちらの実際の名前を記述してね。

 (ぶらっと)

 今コードを追加して再度実行したらユーザーフォーム表示されました！

 その他の動作確認を引き続きやってみます。

 念のためご質問にお答えします。

 ＞・そのフォームは、このマクロブックにあるのかな？

 はい、MENUシートの出荷指示ユーザーフォームを呼び出すボタンと並んで呼び出し用のコマンドボタンがあり、フォームのコードも同じブックにあります。

 ＞・もしそうだとして、そのユーザーフォームの名前は？

 オブジェクト名は“SyukkaForm”と“TourokuForm”です。

 ＞・で、実行時、そのユーザーフォームは呼び出されていた？それとも、呼び出されていない？

 呼び出されていません。
 ただ検索した時に「閉じてもメモリに残っている可能性がある」とあったので一旦ブックを再起動しましたが同じでした（その時は出荷指示フォームだけを最初に起動させようとしました）。

 ＞Module1の列規定と、そちらの実際のシートのレイアウトは合致している？

 再度確認しましたが合致しています。

 ＞日付型で入力されているという前提なんだけど、大丈夫？

 はい書式設定も日付型で、“2011/11/17”のような書式で書いてあります。

（らんきち）

 引当実行まで試してみました。

 今のところ動作自体は正常なのですが、時々指示書作成フォーム呼び出しや引当実行フォーム呼び出しで
 オートメーションエラー、「インデックスが有効範囲にありません」というエラーなどが出ることがあります。
 ただ毎回出るわけではなく、もう一度ボタンを押したら正常に動作したり、さらにもう一度押すとエラーが出たり
 規則性がわかりません。

 もう少し動作テストしてみます。

 ありがとうございます

（らんきち）

 次回からエラーの場合は、
・メッセージに加えてエラーの場所
・オートメーションエラーは、ちょっと別にして、その他のエラーの場合、光っているコードの上の変数に
　マウスをあて　浮かび上がるその変数の値（複数の変数があればそれらすべて）を教えて。

 ところで、ＶＢＥ画面のツール->オプションででてくる画面の全般タグで、エラートラップは
「クラスモジュールで中断」にしてあるかな？もし、そうなっていなかったらエラーが出ても、常に
 ユーザーフォームをShowしようとしているコードが光って、実際のエラーの場所がわからないので
　設定を変更しておいてね。

 (ぶらっと)

 すみませんでした。
 エラートラップは違う設定だったので今設定変更しました。

 そして今エラーが出ました。

 ・「実行時エラー'13'　型が一致しません」
 コードの場所

 make出荷指示書

                     v(i, 2) = CDate(v(i, 2))
 変数の値　i = 1

 ※対象のデータは日付型になっています

 ・「実行時エラー'9'　インデックスが有効範囲にありません」
 コードの場所

 make引当更新データ

             ReDim Preserve v(1 To k)
 変数の値　k = 0

 2つ目のエラー「インデックスが～」は作成された出荷指示書が無い時は確実に出ます。
 （ただしそのエラーの後にもう一度引当実行呼び出しボタンを押すとリストボックスが空欄でフォームが起動します）
 でも指示書がある時も時々出るのでそれが原因かどうかはわかりません…

（らんきち）

 >2つ目のエラー「インデックスが～」は作成された出荷指示書が無い時は確実に出ます。

 ここがクセモノだね。

 >でも指示書がある時も時々出るのでそれが原因かどうかはわかりません…

 といわれると自信がゆらぐんだけど。

 ちょっとチェックしてみる。

 >「実行時エラー'13'　型が一致しません」

 こちらのほうも、出荷依頼データがからっぽということはないのかな？
 そちらで思っている出荷依頼シートとコードが参照しているシートが違うとか。
 (コードは、Constで規定したシート名を使っている）
 いずれにしても、こちらもチェックしてみる。

 追伸）今、こちらでやってみたら両方、それぞれ報告どおりのエラーになった。
　　　なぜ、そちらで出荷依頼データ(Sheet2)がからっぽだとみなされたかは横に置き
　　　このような状態はありうるわけなので、エラー対応をする。

 (ぶらっと)

 以下リバイスお願い
オートメーションエラーは、二次災害的にでていたもので、これで、それもでなくなる（と思う）

 ユーザーフォームモジュールのActivateルーティン

 Private Sub UserForm_Activate()
    Dim k As Long
    Dim sh As Worksheet
    Dim dic As Object
    Dim c As Range
    Dim v As Variant
    Dim i As Long
    Call io商品(fnOpen)
    Select Case Me.Tag
        Case "A"
            If Not make出荷指示書(fnOpen) Then
                CommandButton1.Enabled = False
                CommandButton2.Enabled = False
                CommandButton3.Enabled = False
                Exit Sub
            End If
            Me.Caption = "出荷指示書作成（指示書を作成する出荷コードを選んでください）"
            Call make出荷指示書(fnGetList, v)
            ListBox1.ColumnCount = 3
        Case "B"
            Call make引当更新データ(fnOpen)
            Me.Caption = "引当更新（引当可能在庫の更新を行います。対象の出荷データを選んでください）"
            If Not make引当更新データ(fnGetList, v) Then
                CommandButton1.Enabled = False
                CommandButton2.Enabled = False
                CommandButton3.Enabled = False
            Else
                ListBox1.ColumnCount = 1
            End If
    End Select
    ListBox1.List = v

    '以下はユーザーフォームのプロパティで設定すればコードは不要
    ListBox1.MultiSelect = fmMultiSelectExtended
    CommandButton1.Caption = "実行"
    CommandButton2.Caption = "全て選択"
    CommandButton3.Caption = "全て解除"

 End Sub

 make出荷指示書の　fnOpen

        Case fnOpen
            Set dicO = CreateObject("Scripting.Dictionary")
            With Sheets(shn出荷依頼)  '出荷依頼データ
                If Len(.Range("A2").Value) = 0 Then
                    MsgBox "出荷依頼データがありません"
                    Exit Function
                End If
                For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
                    cd = c.Value
                    s = c.Offset(, 1).Value & "(" & Format(c.Offset(, 2).Value, "#,##0") & ")"
                    If dicO.exists(cd) Then
                        If dicO(cd)(1) <> c.Offset(, 3).Value2 Then
                            MsgBox "出荷コード:" & cd & "の出荷日は全て同じにしてください"
                            Exit Function
                        End If
                        w = dicO(cd)
                        w(2) = w(2) & " " & s
                        dicO(cd) = w
                    Else
                        dicO(cd) = Array(cd, c.Offset(, 3).Value2, s)
                    End If
                 Next
            End With

 make引当更新データ プロシジャ

 Function make引当更新データ(fc As func, Optional v As Variant) As Boolean
    Dim sh As Worksheet
    Dim k As Long

    Select Case fc

        Case fnOpen
            'Nop

        Case fnGetList

            ReDim v(1 To Worksheets.Count)
            For Each sh In Worksheets
                If Left(sh.Name, 5) = "出荷指示_" Then
                    k = k + 1
                    v(k) = sh.Name
                End If
            Next
            If k = 0 Then
                MsgBox "出荷指図シートがありません"
                Exit Function
            Else
                ReDim Preserve v(1 To k)
            End If
        Case fnClose
            'Nop

    End Select

    make引当更新データ = True

 End Function

 (ぶらっと)

ぶらっと様

 ありがとうございます。

 引当更新の方はダイアログボックスが出るようになりました。

 ただ出荷指示書作成の時、出荷データが無いと「インデックスが有効範囲にありません」のエラーが出ます。

 今回の場所はmake出荷指示書の

             With Sheets(shn出荷依頼)  '出荷依頼データ

 です。（shn = ""）

 あとオートメーションエラーは相変わらず出ます。こっちは規則性がさっぱりわかりません…

 明日もう一度テストします

（らんきち）

 > With Sheets(shn出荷依頼)  '出荷依頼データです。（shn = ""）

 そちらの、Module1の先頭のあたりの　Public Const shn出荷依頼 As String = "Sheet2"
これは、実際にはどうなっている？

 それと、なんとなく気になってるんだけど、モジュールの先頭の Option Explicit を消してるなんてことは？

 追記）「出荷データが無いと」ということはありうるの？シートそのものがない？
　　　それならそれで、その手当をすればいいんだけど。

 (ぶらっと)

 make出荷指示書 の fnOpen の最初を以下に。

       Case fnOpen
            Set dicO = CreateObject("Scripting.Dictionary")
            If Not IsObject(Evaluate("'" & shn出荷依頼 & "'!A1")) Then
                MsgBox "出荷依頼データがありません"
                Exit Function
            End If
            With Sheets(shn出荷依頼)  '出荷依頼データ

 しかし苦言を。
できるだけ例外事項をカバーしているつもりだけど、「Ａシートを元にＢシートを作りたい」という質問に対して
コードをアップしたら、「Ａシートがないとエラーになります！！」といわれているようなもの。
Ａシートがない状態もあり得ますと、それは重要な要件として事前に提示してほしいねぇ。

 もう、あるはずのシートがないなんてことはないよね・・・
出荷依頼データに指定された商品の在庫シートがないなんてことは・・・

 (ぶらっと)

ぶらっと様

 本当に、本当に申し訳ございません。

 Aシートが無い状態というのを想定していなかった私のミスです。

自分は「データがあって当然」と思い込んでいたのですが、現場の人にテスト入力してもらうとそういう（Aシートが無い場合）操作をされていて、それで気がつきました。

 それで　Public Const shn出荷依頼 As String = "Sheet2" の件ですが、その現場の人にテストをしてもらった際に
 "Sheet2"の見出しをうっかりクリックして"Sheet2 "（最後に半角スペースが入っている）というシート名に
 変えてしまったみたいなんです。
 今朝もう一度VBAのプロジェクト画面を見直して気がつきました。
 本当に申し訳ないの一言に尽きます；；

 ちなみにモジュールの先頭の Option Explicit は消してません。

 謎のオート－メーションエラーはまだランダムで出ますがこれは引き続きネットなどで調べてみます。

（らんきち）

 オートメーションエラーというのは、原因が様々で、いつも、なんとなくわからずじまいということが多いんだけど
今回のものは、↑のほうでもコメントしたように「通常のエラーによる二次災害」なんだとにらんでいるんだけどね。
（このマクロブックを開いて、何かした実行したときの最初のエラーがオートメーションエラーなのであれば
　この推測は「ハズレ」だけど。）

 ただ、今回のケースで、こうかな？といろいろためしても、このエラー(440)にはならず、通常のエラーになるので
「推測」もあやしいもんだけど。

 もし、どうしても解決せず、かつ、それが発生するところが常に　If UserForms.Count > 0 Then　なのであれば
ここは、１つのユーザーフォームで処理している、出荷指示と引当更新を、「パラレルで」menuシートのボタンから
呼び出せないような排他制御をかけているところなので、全く別の方法にかえてしまえばいいかもしれない。

 (ぶらっと)

ぶらっと様

 本当に色々とありがとうございます。

 今日もテストしてみましたが今日はオートメーションエラーは出ませんでした。

 明日から本格的に運用に入る予定です。（出荷指示書作成と在庫引当のみ）

 また入荷処理なども必要になると思いますが私が実際に入荷処理をしていないのでどのようなものかわからず、
 必要になった時にまた処理の仕方を考えなければならなくなると思います。
 （当分は手入力でやるようですが）

 次は教えていただいたコードを見ながら自分でもある程度はできるようになりたいです。

（らんきち）

 新しいトピの以下の報告について。

 >同じ賞味期限・同じロット番号のものが2行以上あった場合の引当更新で少し不思議なことが起きました

 >すみません、これも後だしみたいになってしまいました

 >とマイナスになってしまいます…

 後だしというより、重要な仕様として、こちらから「在庫シートのキーは賞味期限とロット」と確認
しているところがあるんだけど、気がつかなかったのかな？

 出荷依頼が21個あった時には、わかれるのに・・・という指摘はごもっともだけど、これは単純に
最初の数量が 1個で、21個消化できないので、残りを、次のものからピックアップしているだけ。

 一方、引当更新は、そのキー（賞味期限、ロット）で、最初にマッチしたものを無条件に採用。
これは、ある意味手抜きといえば手抜き。上のほうで「いいわけ」したように、引当更新時は
引当可能数量におさまっているかどうかはチェックしていない。

 ここも、引当可能数量との比較をするということなら、それはそれで、できるけど、ちょっと構造に
影響してくるので、時間はかかるかなぁ。

 (ぶらっと)

ぶらっと様すみません…

 今はとりあえず上記のような現象は手入力で修正していますが、可能ならば引当可能数量と比較して
 マイナスになったり取りこぼしたりしないようにしたいです。
 （一度にいくつもの出荷入力をするとわけがわからなくなるので…）

 やはりレイアウトの構造に問題がありますよね…

 ちなみにマクロブックとデータブックを分ける場合はアドイン（？）を使わなければならないのでしょうか。
 このファイルはネットワーク上の共有ファイルで複数の人が参照するものです。
 検索したところアドインを使う方法やデータ用ブックにコマンドボタンを置いてマクロブックを呼び出す方法などがあって、
 今まで分割して使用したことがないのでどれが適正なのかと思って…

 質問や注文ばかりですみません；；

（らんきち）

 >マイナスになったり取りこぼしたりしないようにしたいです。

 少し時間頂戴ね。

 >ちなみにマクロブックとデータブックを分ける場合はアドイン（？）を使わなければならないのでしょうか。

 必ずしもアドイン等が必要ということはない。
たとえば、当方でやっている仕組みでは、マクロブックが開かれたら、自動的に所定のフォルダにある
所定のブック（在庫.xlsx等）を開いて、マクロでは、それを相手にするという構成。

 どんな構成がやりやすいか、そちらの運用と、コードの実態を見ながら、これも考えてみる。

 (ぶらっと)

 すみません、同じ賞味期限・同じロットの件で追加です。

 別のファイルで、今回作成したものと全く同じレイアウトで同じ作業をするのでそのファイルにも今回のマクロを適用したのですが、
 そのファイルには「同じ賞味期限・同じロット」のものが多数存在します。
 職場の人に「一つにまとめてはいけないのか」と聞いたところ、現在「入荷日の古い順に固めてある」とのこと（ただし入荷日は入っていない）

 つまり今まで「入荷日」という項目を設ておらず、上から単純に入荷したものを記入していき、賞味期限順のソートもしていない状態でした。

 今後「入荷日」の項目に入荷日を入れてもらうことにはしましたが、それでも同じ賞味期限・同じロットが複数存在するのはどうしようもないようです
 （入荷した履歴を残していきたいとのこと）

 そして出荷時は同じ賞味期限・同じロットでも入荷日の古い順に出したいということです。
 これは並び変え時に「賞味期限」「入荷日」両方を昇順に並べて行くようにしますが、次トピの入荷にも関わってくるかと思いまして…

 今まで私としても散々確認してきたのに今更新たな情報を出されてしまって…

 なんだかもう本当に色々とすみません…

（らんきち）

 いろいろ、大変だね。ご苦労さん。
いずれにしても、対応はするよ。ただ、入荷日空白ってのは、なんとか入力してもらおうね。

 (ぶらっと)

 ありがとうございます。

 今ファイルを確認して、入荷日が分かるものは入力し、不明なものは古い順にダミーの日付を入れて（去年の日付など）コメント欄に追記しました。

 今後は入荷日空白にならないようにしてもらいますが、次トピの「入荷処理」を行う時に入荷日空白であればエラーを返すような処理で対応できないかと考えています。

（らんきち）

 引当更新の「手抜きロジック」を出荷指示書作成並みに改善。
なお、在庫シートのレイアウトは、データが３行目からという構成にした方がスッキリすると思うけど
とりあえずは従来通り。最終的にＯＫになった時点で、必要なら変更しよう。

 Module1の  '在庫シート規定 に以下の２行を追加）

 Public Const 入荷日col As String = "B"
 Public Const 入荷数量col As String = "G"

 Module2 の io商品をリプレース。

 Function io商品(fc As func, Optional cd As String, Optional comAbbr As String, _
                Optional qty As Long, Optional dldate As Date, _
                Optional lot As String, Optional syomi As Date) As Variant
    Static dicM As Object
    Dim first As Boolean
    Dim c As Range
    Dim sh As Worksheet
    Dim comID As String
    Dim dKey As Variant
    Dim reqQty As Long
    Dim dDate As Date
    Dim dQty As Long
    Dim dLot As String
    Dim v() As Variant
    Dim setQty As Long
    Dim wk As Variant
    Dim i As Long
    Dim d保留 As Variant
    Dim d賞味期限 As Variant
    Dim dロット As Variant
    Dim d引当可能 As Variant
    Dim dm As Long
    Dim w As Variant
    Dim x As Long
    Dim myCol As Long
    Dim myflag As Boolean
    Dim minQ As Long
    Dim maxQ As Long

    Select Case fc

        Case fnOpen
            Set dicM = CreateObject("Scripting.Dictionary")
            For Each sh In Worksheets
                If Left(sh.Name, 2) = "在庫" Then
                    comAbbr = Mid(sh.Name, 3)
                    Set dicM(comAbbr) = CreateObject("Scripting.Dictionary")
                    For Each c In sh.Range(商品IDCol & "6", sh.Range(商品IDCol & sh.Rows.Count).End(xlUp))
                        i = c.Row
                        With sh
                            d保留 = .Cells(i, 保留Col).Value
                            d賞味期限 = .Cells(i, 賞味期限Col).Value
                            dロット = .Cells(i, ロットCol).Value
                            d引当可能 = .Cells(i, 引当可能Col).Value
                        End With

                        If Len(d保留) = 0 And Len(d賞味期限) > 0 Then '保留マーク空白/賞味期限あり
                            dicM(comAbbr)(dicM(comAbbr).Count + 1) = Array(d賞味期限, dロット, d引当可能)
                        End If
                    Next
                End If
            Next

        Case fnGet
            If Not dicM.exists(comAbbr) Then Exit Function
            first = True
            reqQty = qty
            comID = "登録なし"
            wk = Application.Match(comAbbr, Sheets(shn商品一覧).Columns(ABBRCol), 0)
            If IsNumeric(wk) Then
                comID = Sheets(shn商品一覧).Cells(wk, IDCol).Value
            End If
            For Each dKey In dicM(comAbbr)
                dDate = dicM(comAbbr)(dKey)(0)
                dLot = dicM(comAbbr)(dKey)(1)
                dQty = dicM(comAbbr)(dKey)(2)
                wk = dicM(comAbbr)(dKey)
                If dldate <= dDate And dQty > 0 Then
                    If dQty >= reqQty Then
                        setQty = reqQty
                        wk(2) = wk(2) - setQty
                    Else
                        setQty = dQty
                        wk(2) = 0
                    End If
                    reqQty = reqQty - setQty
                    dicM(comAbbr)(dKey) = wk
                    If first Then
                        ReDim v(1 To 7, 1 To 1)
                        first = False
                    Else
                        ReDim Preserve v(1 To UBound(v, 1), 1 To UBound(v, 2) + 1)
                        wk(1) = 0
                    End If
                    v(1, UBound(v, 2)) = cd
                    v(2, UBound(v, 2)) = comAbbr
                    v(3, UBound(v, 2)) = dDate
                    v(4, UBound(v, 2)) = dLot
                    v(5, UBound(v, 2)) = setQty
                    v(6, UBound(v, 2)) = dldate
                    v(7, UBound(v, 2)) = comID
                End If
                If dicM(comAbbr)(dKey)(1) = 0 Then dicM(comAbbr).Remove dKey
                If reqQty = 0 Then Exit For
            Next
            If Not first Then
                v = WorksheetFunction.Transpose(v)
                dm = getDimension(v)
                If dm = 1 Then   '１次元配列なら１行の２次元に
                    ReDim w(1 To 1, 1 To UBound(v))
                    For x = 1 To UBound(v)
                        w(1, x) = v(x)
                    Next
                    v = w
                End If
                io商品 = v
            End If

        Case fnSort
            For Each sh In Worksheets
                If Left(sh.Name, 2) = "在庫" Then
                    With sh.Range(商品IDCol & "6", sh.Range(商品IDCol & sh.Rows.Count).End(xlUp)).EntireRow
                        .Sort Key1:=.Columns(賞味期限Col), Order1:=xlAscending, _
                              Key2:=.Columns(入荷日col), Order2:=xlAscending, _
                              key3:=.Columns(ロットCol), order3:=xlAscending, _
                              Header:=xlNo
                    End With
                End If
            Next

        Case fnRegister

            myflag = False

            With Sheets("在庫" & comAbbr)
                x = .Range(商品IDCol & "6", .Range(商品IDCol & .Rows.Count).End(xlUp)).Rows.Count
                If cd = "PM" Or cd = "PM2" Then
                    If cd = "PM" Then
                        myCol = Columns(指示PMCol).Column
                    ElseIf cd = "PM2" Then
                        myCol = Columns(指示PM2Col).Column
                    End If
                    minQ = WorksheetFunction.Min(.Cells(6, myCol).Resize(x))
                    maxQ = WorksheetFunction.Max(.Cells(6, myCol).Resize(x))

                    If minQ <> 0 Or maxQ <> 0 Then
                        If MsgBox(comAbbr & "-" & cd & "はすでに引当済みです" & vbLf & _
                                "上書きしますか？", vbYesNo) = vbYes Then myflag = True
                    Else
                        myflag = True
                    End If
                Else
                    For myCol = Columns(履歴開始Col).Column To Columns(履歴終了Col).Column
                        If Len(.Cells(4, myCol)) = 0 Then
                            myflag = True
                            Exit For
                        End If
                        If .Cells(4, myCol).Value = dldate And .Cells(5, myCol).Value = cd Then
                            If MsgBox(comAbbr & "-" & cd & "-" & dldate & "はすでに引当済みです" & vbLf & _
                                "上書きしますか？", vbYesNo) = vbYes Then myflag = True
                            Exit For
                        End If
                    Next
                End If

                If myflag Then
                    .Cells(6, myCol).Resize(x).ClearContents
                    If cd <> "PM" Or cd <> "PM2" Then .Cells(4, myCol).Value = dldate
                    .Cells(5, myCol).Value = cd
                End If

                io商品 = myflag

            End With

        Case fnAllocate
            '在庫シート
            myflag = False
            With Sheets("在庫" & comAbbr)
                If cd = "PM" Or cd = "PM2" Then
                    myflag = True
                    If cd = "PM" Then
                        myCol = Columns(指示PMCol).Column
                    ElseIf cd = "PM2" Then
                        myCol = Columns(指示PM2Col).Column
                    End If
                Else
                    For myCol = Columns(履歴開始Col).Column To Columns(履歴終了Col).Column
                        If .Cells(4, myCol).Value = dldate And .Cells(5, myCol).Value = cd Then
                            myflag = True
                            Exit For
                        End If
                    Next
                End If

                reqQty = qty

                For i = 6 To .Range(商品IDCol & .Rows.Count).End(xlUp).Row
                    d賞味期限 = .Cells(i, 賞味期限Col)
                    dLot = .Cells(i, ロットCol)
                    dQty = .Cells(i, 引当可能Col)
                    If syomi = d賞味期限 And dQty > 0 Then
                        If dQty >= reqQty Then
                            setQty = reqQty
                            dQty = dQty - setQty
                        Else
                            setQty = dQty
                            dQty = 0
                        End If
                        reqQty = reqQty - setQty
                        .Cells(i, myCol).Value = .Cells(i, myCol).Value + setQty
                    End If
                    If reqQty = 0 Then Exit For
                Next

                If reqQty > 0 Then
                    MsgBox "引当可能数量不足により以下の内、" & reqQty & "が引当されませんでした" & vbLf & _
                           cd & " " & comAbbr & " " & " " & syomi & " " & lot
                End If

                io商品 = myflag

            End With

        Case fnClose
            If Not dicM Is Nothing Then
                dicM.RemoveAll
                Set dicM = Nothing
            End If

    End Select

 End Function

 (ぶらっと)

ぶらっと様

ありがとうございます。

引当更新うまくいきました！

お手数をおかけします…

（らんきち）

コメント返信：

[ 一覧(最新更新順) ]

[[20111114163123]] 『Excelの先入先出の方法★その３』（らんきち） ページの最後に飛ぶ

[[20111114163123]]　『Excelの先入先出の方法★その３』（らんきち）　ページの最後に飛ぶ