Results of 1 - 1 of about 37671 for IF (0.008 sec.)
- [[20111114163123]]
- #score: 1591
- @digest: 6a476c472ac50c6778bbde2f7a334b28
- @id: 56643
- @mdate: 2011-11-24T02:09:25Z
- @size: 52735
- @type: text/plain
- #keywords: comabbr (169842), 荷指 (135799), 引当 (117378), 当更 (107068), 荷依 (94442), 頼デ (79180), reqqty (77741), 賞味 (76669), 当可 (74291), setqty (63551), dicm (61457), dldate (60299), fnopen (56064), 味期 (50887), 出荷 (46247), 示書 (38367), myflag (37342), make (28162), 指示 (28120), 品id (26777), mycol (25065), 期限 (18663), 書作 (17627), 入荷 (15248), 荷日 (14557), 依頼 (13401), optional (12408), 在庫 (10827), 商品 (7925), cd (6928), ーフ (6889), listbox1 (6190)
- 『Excelの先入先出の方法★その3』（らんきち）
[[20111110145634]] の続きです。 ＞在庫の中には引当済みで、未出庫 この「引当済みで未出庫」がN列とQ列になります。 前日の「倉庫現在庫」を当日に「前日在庫」に移した時にN列とQ列も手入力で移しますので、 引当可能在庫に「前日在庫」からN列とQ列が差し引かれた数字が入ることになります。 なんかわかりにくくてすみません… ---- ということは、R列以降の、その他出荷指示（? PM でも PM2 でもない出荷指示）は、 「必ず、その日の内に出荷される。積み残されることはない」というルールなんだね? ということなら、了解。 (ぶらっと) ---- ＞必ず、その日の内に出荷される。積み残されることはない はい、そうなります。 （らんきち） ---- ぶらっと様 すみません、引き続き動作確認などしていたのですが、いつの間にか「Menu」シートのコマンドボタンを押して 出荷指示のユーザーフォームを呼び出そうとすると、標準モジュール1 Sub 出荷指示() If IsFormLoaded Then Exit Sub With UserForm1 .Tag = "A" '出荷指図 .Show vbModeless End With End Sub With UserForm1 のところで「型が一致しません」というエラーが出るようになりました。 昨日やったのは商品一覧に商品を登録するユーザーフォームを作ったことです。 UserForm1 のコードを試しに全部コメントブロックにしたら呼び出しだけはできました。 別のユーザーフォームを作ったのが悪かったのか、在庫シートのレイアウトを変えたのがいけなかったのか… どの時点でエラーが出るようになったのかはっきりしません。 もうちょっと試してみます。 （らんきち） ---- 上のレスについては、いったん今回アップするコードで、もう一度試してみて。 まとまって本件に取り組み時間がとれなかったので、随分、間があいてしまい恐縮。 とりあえず書き上げたのでコードをアップするけど・・・ ちょっと悩んだ。コードそのものが仕様の二転三転でごちゃついていることもあるけど そもそもが、データ処理にはふさわしいと思えないような（失礼）現行の在庫シートのレイアウトと これも、あまり「システム的」とはいえないような人間系の処理実態を反映させているので データの持ち方が、ちょっと複雑怪奇。プログラム使用書もない状態で、今後、これを、そちらで メンテしくれるかどうか・・・? でも、まぁ、がんばってもらうことにして。 前触れで。 1.新しく 「出荷引当実行」プロシジャを準備した。menuシートにボタンを追加して、そのボタンに このプロシジャをマクロ登録してください。 2.出荷指示書作成「兼」出荷引当 機能は、最終的には消した。なので、連続して作業する場合は menuでボタンを選びなおしてね。 3.Module1 の先頭で 商品一覧シート、在庫シートの列の規定をしている。 ここをもう一度、よく確認願う。 なお、ここを変更すれば、コード変更なしで、レイアウト変更に対応できる。 4.この列規定の意味するところは プログラムでは、この項目「しか」相手にしていない。（在庫数量関係はいっさい参照していない） 5.出荷指図書作成では引当可能在庫を参照しているが、引当実行では、ちょっと手を抜いてチェックせず 出荷指示書にある数量をそのまま使っている。 6.引当可能数量は、そちらの計算式で、「常に正しく」値がセットされているということが大前提。 プログラムではいっさい、ここを変更していない。 7.出荷指示書作成の元ねたは出荷依頼データ、出荷引当実行の元ねたはできあがっている指示書シート。 8.いずれも、処理の最後にこのブックを自動保存している。ここが、結構、思いようで実際には処理が終了 しているけど、終了メッセージがでるまで、時間がかかるかもしれない。 9.なお、用意した機能は、基本的に「新規作成・登録」。実際の業務では「取消」や「訂正」も 必要になると思うけど、以下のように運用してほしい。 1）出荷指示書 取消 シートを削除する。 訂正 新たに新規作成して上書きするか、あるいはシートに直接手入力で変更。 2）引当 まず、在庫シートに直接手入力で変更（あるいは列削除）することが考えられる。 同じ引当をするとメッセージがでて、上書きも可能になっているので、これを利用して 指示書側を訂正しておいて引当実行ということも可能。（取消の場合は指示書数量をゼロにしておく） (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 '1次元配列なら1行の2次元に 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 = " " 'スペース 商品ブレーク ただし1行ゆえ小計なし 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”のような書式で書いてあります。 （らんきち） ---- 引当実行まで試してみました。 今のところ動作自体は正常なのですが、時々指示書作成フォーム呼び出しや引当実行フォーム呼び出しで オートメーションエラー、「インデックスが有効範囲にありません」というエラーなどが出ることがあります。 ただ毎回出るわけではなく、もう一度ボタンを押したら正常に動作したり、さらにもう一度押すとエラーが出たり 規則性がわかりません。 もう少し動作テストしてみます。 ありがとうございます （らんきち） ---- 次回からエラーの場合は、 ・メッセージに加えてエラーの場所 ・オートメーションエラーは、ちょっと別にして、その他のエラーの場合、光っているコードの上の変数に マウスをあて 浮かび上がるその変数の値（複数の変数があればそれらすべて）を教えて。 ところで、VBE画面のツール->オプションででてくる画面の全般タグで、エラートラップは 「クラスモジュールで中断」にしてあるかな?もし、そうなっていなかったらエラーが出ても、常に ユーザーフォームを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シートを元にBシートを作りたい」という質問に対して コードをアップしたら、「Aシートがないとエラーになります!!」といわれているようなもの。 Aシートがない状態もあり得ますと、それは重要な要件として事前に提示してほしいねぇ。 もう、あるはずのシートがないなんてことはないよね・・・ 出荷依頼データに指定された商品の在庫シートがないなんてことは・・・ (ぶらっと) ---- ぶらっと様 本当に、本当に申し訳ございません。 Aシートが無い状態というのを想定していなかった私のミスです。 自分は「データがあって当然」と思い込んでいたのですが、現場の人にテスト入力してもらうとそういう（Aシートが無い場合）操作をされていて、それで気がつきました。 それで Public Const shn出荷依頼 As String = "Sheet2" の件ですが、その現場の人にテストをしてもらった際に "Sheet2"の見出しをうっかりクリックして"Sheet2 "（最後に半角スペースが入っている）というシート名に 変えてしまったみたいなんです。 今朝もう一度VBAのプロジェクト画面を見直して気がつきました。 本当に申し訳ないの一言に尽きます;; ちなみにモジュールの先頭の Option Explicit は消してません。 謎のオート-メーションエラーはまだランダムで出ますがこれは引き続きネットなどで調べてみます。 （らんきち） ---- オートメーションエラーというのは、原因が様々で、いつも、なんとなくわからずじまいということが多いんだけど 今回のものは、↑のほうでもコメントしたように「通常のエラーによる二次災害」なんだとにらんでいるんだけどね。 （このマクロブックを開いて、何かした実行したときの最初のエラーがオートメーションエラーなのであれば この推測は「ハズレ」だけど。） ただ、今回のケースで、こうかな?といろいろためしても、このエラー(440)にはならず、通常のエラーになるので 「推測」もあやしいもんだけど。 もし、どうしても解決せず、かつ、それが発生するところが常に If UserForms.Count > 0 Then なのであれば ここは、1つのユーザーフォームで処理している、出荷指示と引当更新を、「パラレルで」menuシートのボタンから 呼び出せないような排他制御をかけているところなので、全く別の方法にかえてしまえばいいかもしれない。 (ぶらっと) ---- ぶらっと様 本当に色々とありがとうございます。 今日もテストしてみましたが今日はオートメーションエラーは出ませんでした。 明日から本格的に運用に入る予定です。（出荷指示書作成と在庫引当のみ） また入荷処理なども必要になると思いますが私が実際に入荷処理をしていないのでどのようなものかわからず、 必要になった時にまた処理の仕方を考えなければならなくなると思います。 （当分は手入力でやるようですが） 次は教えていただいたコードを見ながら自分でもある程度はできるようになりたいです。 （らんきち） ---- 新しいトピの以下の報告について。 >同じ賞味期限・同じロット番号のものが2行以上あった場合の引当更新で少し不思議なことが起きました >すみません、これも後だしみたいになってしまいました >とマイナスになってしまいます… 後だしというより、重要な仕様として、こちらから「在庫シートのキーは賞味期限とロット」と確認 しているところがあるんだけど、気がつかなかったのかな? 出荷依頼が21個あった時には、わかれるのに・・・という指摘はごもっともだけど、これは単純に 最初の数量が 1個で、21個消化できないので、残りを、次のものからピックアップしているだけ。 一方、引当更新は、そのキー（賞味期限、ロット）で、最初にマッチしたものを無条件に採用。 これは、ある意味手抜きといえば手抜き。上のほうで「いいわけ」したように、引当更新時は 引当可能数量におさまっているかどうかはチェックしていない。 ここも、引当可能数量との比較をするということなら、それはそれで、できるけど、ちょっと構造に 影響してくるので、時間はかかるかなぁ。 (ぶらっと) ---- ぶらっと様すみません… 今はとりあえず上記のような現象は手入力で修正していますが、可能ならば引当可能数量と比較して マイナスになったり取りこぼしたりしないようにしたいです。 （一度にいくつもの出荷入力をするとわけがわからなくなるので…） やはりレイアウトの構造に問題がありますよね… ちなみにマクロブックとデータブックを分ける場合はアドイン（?）を使わなければならないのでしょうか。 このファイルはネットワーク上の共有ファイルで複数の人が参照するものです。 検索したところアドインを使う方法やデータ用ブックにコマンドボタンを置いてマクロブックを呼び出す方法などがあって、 今まで分割して使用したことがないのでどれが適正なのかと思って… 質問や注文ばかりですみません;; （らんきち） ---- >マイナスになったり取りこぼしたりしないようにしたいです。 少し時間頂戴ね。 >ちなみにマクロブックとデータブックを分ける場合はアドイン（?）を使わなければならないのでしょうか。 必ずしもアドイン等が必要ということはない。 たとえば、当方でやっている仕組みでは、マクロブックが開かれたら、自動的に所定のフォルダにある 所定のブック（在庫.xlsx等）を開いて、マクロでは、それを相手にするという構成。 どんな構成がやりやすいか、そちらの運用と、コードの実態を見ながら、これも考えてみる。 (ぶらっと) ---- すみません、同じ賞味期限・同じロットの件で追加です。 別のファイルで、今回作成したものと全く同じレイアウトで同じ作業をするのでそのファイルにも今回のマクロを適用したのですが、 そのファイルには「同じ賞味期限・同じロット」のものが多数存在します。 職場の人に「一つにまとめてはいけないのか」と聞いたところ、現在「入荷日の古い順に固めてある」とのこと（ただし入荷日は入っていない） つまり今まで「入荷日」という項目を設ておらず、上から単純に入荷したものを記入していき、賞味期限順のソートもしていない状態でした。 今後「入荷日」の項目に入荷日を入れてもらうことにはしましたが、それでも同じ賞味期限・同じロットが複数存在するのはどうしようもないようです （入荷した履歴を残していきたいとのこと） そして出荷時は同じ賞味期限・同じロットでも入荷日の古い順に出したいということです。 これは並び変え時に「賞味期限」「入荷日」両方を昇順に並べて行くようにしますが、次トピの入荷にも関わってくるかと思いまして… 今まで私としても散々確認してきたのに今更新たな情報を出されてしまって… なんだかもう本当に色々とすみません… （らんきち） ---- いろいろ、大変だね。ご苦労さん。 いずれにしても、対応はするよ。ただ、入荷日空白ってのは、なんとか入力してもらおうね。 (ぶらっと) ---- ありがとうございます。 今ファイルを確認して、入荷日が分かるものは入力し、不明なものは古い順にダミーの日付を入れて（去年の日付など）コメント欄に追記しました。 今後は入荷日空白にならないようにしてもらいますが、次トピの「入荷処理」を行う時に入荷日空白であればエラーを返すような処理で対応できないかと考えています。 （らんきち） ---- 引当更新の「手抜きロジック」を出荷指示書作成並みに改善。 なお、在庫シートのレイアウトは、データが3行目からという構成にした方がスッキリすると思うけど とりあえずは従来通り。最終的にOKになった時点で、必要なら変更しよう。 Module1の '在庫シート規定 に以下の2行を追加） 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 '1次元配列なら1行の2次元に 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 (ぶらっと) ---- ぶらっと様 ありがとうございます。 引当更新うまくいきました! お手数をおかけします… （らんきち）... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/201111/20111114163123.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97018 documents and 608144 words.
訪問者：