[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数の条件を指定して伝票を作成②』（にょろ）
の続きです。
zz = shW.Range("B" & shW.Rows.Count).End(xlUp).Row - 1 ← zz = 56
If zz = 1 Then ← zz = 56
MsgBox "データが抽出されていません"
Exit Sub
End If
z = z \ 50 ← z = 0
If zz Mod 50 > 0 Then z = z + 1 ← zz = 56、z = 1
です。
で、この件は、前とぴの最後で解決ということでいいんだよね？ となると、あとは後顧の憂いなく（？？）集計表。 まだ、入力表の１行と集計表の１行とが、どういう紐つけなのか、１：１なのか N:1なのかが不明。 伝票枚数の理解もいまいち、いま２なので、誤解しているところは多いと思うけど、また指摘をもらいながらチューニングしていこう。
ということで、たぶん、早晩、ベータ版をアップできると思う。
(ぶらっと)
あと、ブックのアクティブ化の件ですが前回の
>Set shW = ThisWorkbook.Sheets("作業") にかえて試してみてくれる？
で解決できませんでした…
集計についてですが、基本的にはよくあるデータ集計のように
商品コード 商品名 数量 日付 AAA あああ 10 2012/5/30 AAA あああ 25 2012/6/1 BBB いいい 20 2012/6/1 AAA あああ 15 2012/6/2 CCC ううう 5 2012/6/2 AAA あああ 30 2012/6/2 BBB いいい 15 2012/6/2
このような入力表から
条件：6/1～6/30の日付の物を集計 商品コード 商品名 数量 AAA あああ 70 BBB いいい 35 CCC ううう 5
このように商品毎に個数を集計するんですが、その集計した内訳に「指定日」と「指定日ごとの個数」が入るような感じです。
ちなみに集計の際はユーザーフォームで
「種別」（単品か抱合せか） 「集計開始日」 「集計締め日」 「便名」 「区分」
をテキストボックス・コンボボックスで指定してコマンドボタンで集計実行というイメージにしてます。
説明が下手ですみません…
※追加 アクティブブックの件は、ユーザーフォームのShowModalをFalseにすることで対応できました
（にょろ）
>あと、ブックのアクティブ化の件ですが前回の
>Set shW = ThisWorkbook.Sheets("作業") にかえて試してみてくれる？
>で解決できませんでした…
あぁ、課題を取り違えていた。
要は、モーダル表示されているので、ブックがさわれないということだったんだね。
で、それをモードレス表示で対応というところは、まったく問題ないけど、それとは別に
複数ブックがあって、どれが最前面ブックか保証の限りではない状況なので
Set shW = ThisWorkbook.Sheets("作業") この記述は必須。よろしく。
(ぶらっと)
>Set shW = ThisWorkbook.Sheets("作業")
これは記述しました。
あとすみません、1件教えてください。 作成された伝票ブックに新規シートを追加する際、 ・ユーザーフォームで連続して（伝票ブックを閉じずに）新しい伝票シートを追加 ・伝票ブックを閉じた状態で新しい伝票シートを追加 これは問題ないのですが、 ・一旦閉じた伝票ブックを手動で開いて新しく伝票シートを追加 という手順になると 「同じ名前の伝票ブックが既にあるから「はい」を押すと以前の内容が破棄され「いいえ」を押すと新規ブックで開きます」 というようなメッセージが出て「いいえ」にすると「Openメソッドで失敗しました」のエラーが出ます。
メッセージとエラーになる理由はよくわかるのですが、実際に伝票を扱う人がExcel初心者の人が多いので、 何らかの方法でこのエラーを回避できないかと… 例えば「同じ名前の伝票ブックを開いてます。これに追加しますか？ Yes/No」でYes/Noを選択、Noなら「一旦伝票ブックを閉じてください」 のメッセージを出すとか… あるいは追加のブックを「120606_単品(2)」と、シート名のように番号をふるか… （「実行時エラー」「デバッグ」の画面が出るのを防ぎたいんです…）
無理かもしれませんが、できるかどうかお教えください
（にょろ）
障害の状況は理解できたけど、まず、その前に。 メッセージは "すでに●●●が存在します。既存ブックに追加しますか？" というものだね。
存在しなければ最初から、既定の名前でブックを作る。 で、存在した場合、上記メッセージをだし、 【はい】 なら既存のブックを呼び出して、そこにシートを【追加】する。【破棄】はしない。 この時、同名のシートがすでにあれば シート名(2) といった名前で作成している。
で、【いいえ】 なら、既に存在するブックは呼び出さず、新規ブック（たとえば Book1)として作成。 最終的に、操作者に、任意の名前で【手作業】で保存してもらう。 (もちろん、既存ブックを上書きする操作もありうると思う）
で、本題。 エラーになるのは、【いいえ】ということだけど、ほんと？ 【はい】のときじゃないの？ もともと、一度作成した伝票ブックは、次の操作の前に【閉じてもらう】ことを想定したコードになっていて これまでの【不具合対応】で、開きっぱなしになっている場合の対応をしてきたけど、【はい】の場合に対処するのを 忘れていた。
【はい】の場合、その呼び出そうとするブックが、いま、作られて画面に残っているブックと同じ場合は たしかに、オープンエラーになる。
なので、開く前にそのチェックをいれようと思うけど、その前提は、現在の障害が、【はい】のときに発生しているということ。 この点、確認もらえれば対応コードをアップするので、よろしく。
(ぶらっと)
エラーの件ですが、先程は確かに「同名のファイルが存在するので…」というようなエラーが出て破棄するかどうか 聞いてきたのですが、今同じことをやっても再現しませんでした… 他に色々試しましたが再現しないので、何か他の原因かもしれません。 また現象が発生したらその時に再現性を調べます。 ちなみに「ブック開いたまま」で「追加しますか？」→「はい」でもエラーは出ませんでした。 私の手順が違うのでしょうか…
その代わりというか、別の現象です。
「伝票作成」のユーザーフォームで、伝票シートを作成した際に一旦ユーザフォームのコントロールをクリアすればいいのですが、 一部分（例えば日付だけとか、「区分」「便名」を変えるとか）を変更してそのままコマンドボタン1を実行すると（ユーザーフォームを閉じないで９ 「インデックスが有効範囲にありません」
If DataID = "単品" Then
Set sh = Sheets("単品データ") ←ここが反転
Else
Set sh = Sheets("抱合せデータ")
End If
となります。
続けて実行するとDataIDを読み込むのに失敗するのでしょうか？
（にょろ）
>ちなみに「ブック開いたまま」で「追加しますか？」→「はい」でもエラーは出ませんでした。
こちらの2010でも、今確認。2003ではエラーになったような記憶があったので。 もしかしたら、記憶違いかもしれないし、2007では、エラーにならないように対応されたのかもしれない。
なので、本件は、しばらく、そっとしておくということでいいね。
>Set sh = Sheets("単品データ") ←ここが反転
う～ん・・ 以前に ThisWorkbook.Sheets("単品データ") や Thisworkbook.Sheets("抱合せデータ")
このように変更したと思うんだけど？
(ぶらっと)
そろそろ、ころあい（？）なので集計表ベータバージョンをアップするね。 まだ伝票番号のカウントのルールを筆頭にわからないところが多い中で、てさぐりで書いたコードなので 実行して不都合なところが少なくないと思うけど、まずは試して。
"集計表 単品" および "集計表 抱合せ" というシートを作り、それぞれの１行目にタイトルをセットして実行してね。
Sub Test3単品()
'引数はテキストボックスや、コンボボックス入力を想定して文字列
Call 集計表作成("単品", "2012/5/28", "2012/6/1", "1便", "通常")
End Sub
Sub Test3抱合せ()
'引数はテキストボックスや、コンボボックス入力を想定して文字列
Call 集計表作成("抱合せ", "2012/5/28", "2012/5/28", "3便", "通常")
End Sub
Sub 集計表作成(DataID As String, FromDate As String, ToDate As String, DlvCycle As String, DlvType As String)
Dim fDate As Date
Dim tDate As Date
Dim shF As Worksheet
Dim shT As Worksheet
Dim dicD As Object
Dim dicE As Object
Dim dicC As Object
Dim w As Variant
Dim c As Range
Dim dKey As Variant
Dim dInpDate As Date
Dim dCycle As String
Dim dType As String
Dim dSfx As String
Dim dNo As String
Dim dCom As String
Dim dVcnt As Long
Dim dPcs As Long
Dim dRsv As Variant
Dim dBase(1 To 6) As Variant
Dim z As Long
Dim i As Long
Dim x As Long
Application.ScreenUpdating = False
If DataID = "単品" Then
Set shF = Sheets("単品データ")
Set shT = Sheets("集計表 単品")
Else
Set shF = Sheets("抱合せデータ")
Set shT = Sheets("集計表 抱合せ")
End If
fDate = FromDate
tDate = ToDate
Set dicD = CreateObject("Scripting.Dictionary") '集計データ用
Set dicE = CreateObject("Scripting.Dictionary") '枝番管理用
Set dicC = CreateObject("Scripting.Dictionary") '商品代表行用
For Each c In shF.Range("A2", shF.Range("A" & shF.Rows.Count).End(xlUp))
dInpDate = c.Offset(, 1).Value
dCycle = c.Offset(, 2).Value
dType = c.Offset(, 3).Value
dSfx = c.Offset(, 4).Value
dNo = c.Offset(, 6).Value
dCom = c.Offset(, 8).Value
dVcnt = c.Offset(, 10).Value
dPcs = c.Offset(, 11).Value
dRsv = c.Offset(, 12).Value
dKey = dRsv & vbTab & dCom
If dInpDate >= FromDate And dInpDate <= ToDate And dCycle = DlvCycle And dType = DlvType Then
If Not dicD.exists(dKey) Then
dBase(1) = dNo
dBase(2) = dCom
dBase(5) = dRsv
dicD(dKey) = dBase
End If
If Not dicC.exists(dCom) Then dicC(dCom) = dKey
w = dicD(dKey)
If DataID = "単品" Or (Not DataID = "単品" And Not dicE.exists(dSfx)) Then w(3) = w(3) + dVcnt
dicE(dSfx) = True
w(6) = w(6) + dPcs
dicD(dKey) = w
w = dicD(dicC(dCom))
w(4) = w(4) + dPcs
dicD(dicC(dCom)) = w
End If
Next
If dicD.Count = 0 Then
MsgBox "対象データがありません"
Else
shT.UsedRange.Offset(1).ClearContents
shT.Range("A2").Resize(dicD.Count, 6).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicD.items))
shT.Cells.Sort Key1:=shT.Columns("B"), Order1:=xlAscending, Header:=xlYes
shT.Select
Application.ScreenUpdating = True
MsgBox "集計が完了しました"
End If
End Sub
(ぶらっと)
> う～ん・・ 以前に ThisWorkbook.Sheets("単品データ") や Thisworkbook.Sheets("抱合せデータ")
このように変更したと思うんだけど？
すみません、
Function 抽出(DataID As String, OutDate As String, DlvCycle As String, DlvType As String) As Long
ここの部分のThisWorkbook.Sheets("単品データ") を修正していませんでした…
（最初標準モジュールに書いたのをユーザーフォームモジュールに移して、標準モジュールにコードを残したままだったのをそっちを扱っていました）
あと、集計表のコードありがとうございました！ それで試していて気付いたのですが…
期間毎の集計も、単品・抱合せ「便名」「区分」ごとに行うので、現状では例えば 「単品_1便_通常」の集計を行った後「単品_2便_通常」の集計をすると「単品_1便_通常」のデータが上書きされて消えてしまいますよね…
これを、伝票作成のように「集計用原紙」の雛形を作り、それぞれ別のシートにして作成した方がよいのかと今気づきました…
あと伝票枚数なんですが、今の集計では指定日が別であった場合、同じ商品の伝票枚数の合計が出ません。 （指定日毎の枚数になります） 伝票の合計は必要なので、別に列を作った方がよいでしょうか？ （C列に合計枚数、D列に指定日毎の枚数、というように）
後出しで申し訳ございません。よろしくお願いいたします。
（にょろ）
集計表の追加要件、ちょっと考えてみるので時間くださいね。
例の、二重に開いて破棄がなんたらで、キャンセルおすとエラーになった件、思い出した。 (すぐに回答できないのが、アル中マイマーがかなり進んできているシグナルかなぁ・・・）
開かれているブックに変更が加えられていなければ、もう一度開いて、すでに開かれている者と取り替えても 問題はないけど、開かれているブックに変更が加えられていたとすると、フォルダから変更前のブックが読み込まれて いれかわるんだけど、それでいいの？ というメッセージ。で、はい なら、変更を無視して開き直すんだけど いいえ だとエラーになる。
やはり、ここも手当が必要だね。当面は、はい で逃げてくれる？
(ぶらっと)
>開かれているブックに変更が加えられていたとすると… あ、そうなんですね！ そういえば伝票ブックのレイアウト（印刷範囲の変更など）をした時に起きたと思います。
>当面は、はい で逃げてくれる？ 了解いたしました。 よろしくお願いいたします。
（にょろ）
遅くなって申し訳ない。とりあえず以下の対応をしたので、伝票作成 と 集計表作成 と getSheetName をリバイスお願い。 getSheetName は共通プロシジャにするので Private 指定をなくしておいた。（別モジュールから呼び出されてもＯＫなように）
１．伝票作成
もし、今から作ろうとする伝票ブックと同じ名前のブックが、閉じられずにエクセル上にあれば
エラーメッセージをだして、閉じないと実行できないようにした。（ちょっと手抜きだけど）
２．集計表
原紙方式導入。原紙の名前は "原紙 集計表 単品" と "原紙 集計表 抱合せ"
できあがる集計表シートは、"集計表 単品" や "集計表 抱合せ" のあとに 必要なら(2),(3)とかをつける。
なお、指定日ごとの伝票枚数だけど、現在、個数については前のほうに代表、後ろのほうに個別になっているので
伝票枚数も、Ｄ列にするのではなく、Ｃ，Ｄ列はいままでのまま。あらたにＦ列を指定日ごとの伝票枚数、
今までのＦ列の指定日ごとの個数をＧ列に、かってに決めて処理をしている。
★ただし、なんども言っているように、そもそも、伝票枚数のカウントについて、まだわかっていない。 上記対応後、テストデータで実行してみたけど、結果は、なんだかふにおちない。 もう一度、単品、抱合せ とれぞれで、伝票枚数（代表と個別と）のカウントルールを教えて。
Sub 伝票作成(DataID As String)
'引数はテキストボックスや、コンボボックス入力を想定して文字列
'DataID "単品" かそれ以外か
Dim shG As Worksheet
Dim shW As Worksheet
Dim shD As Worksheet
Dim zz As Long
Dim z As Long
Dim i As Long
Dim x As Long
Dim wb As Workbook
Dim flag As Boolean
Dim fName As String
Dim fPath As String
Dim newFlag As Long
Dim ckBook As Workbook
Application.ScreenUpdating = False
If DataID = "単品" Then
Set shG = ThisWorkbook.Sheets("原紙 単品")
Else
Set shG = ThisWorkbook.Sheets("原紙 抱合せ")
End If
Set shW = ThisWorkbook.Sheets("作業")
zz = shW.Range("B" & shW.Rows.Count).End(xlUp).Row - 1
If zz = 0 Then
MsgBox "データが抽出されていません"
Exit Sub
End If
fPath = ThisWorkbook.Path & "\"
'12_05_28_単品
fName = Format(CDate(shW.Range("B2").Value), "yy""_""mm""_""dd") & "_" & DataID & ".xlsx"
On Error Resume Next
Set ckBook = Workbooks(fName)
On Error GoTo 0
If Not ckBook Is Nothing Then
MsgBox "まだエクセル上に" & fName & "が開かれたままになっています" & vbLf & _
"これを閉じてから実行してください"
Exit Sub
End If
newFlag = 0
If Len(Dir(fPath & fName)) > 0 Then 'ブックが存在する
If MsgBox("すでに" & fName & "が存在します。既存ブックに追加しますか？", vbYesNo) = vbYes Then
Set wb = Workbooks.Open(fPath & fName)
Else
newFlag = 1
End If
Else
newFlag = 2
End If
z = zz \ 50
If zz Mod 50 > 0 Then z = z + 1
For i = 1 To z
If Not flag And newFlag <> 0 Then
shG.Copy
Set wb = ActiveWorkbook
If newFlag = 2 Then wb.SaveAs fPath & fName
flag = True
Else
shG.Copy After:=wb.Sheets(Sheets.Count)
End If
Set shD = ActiveSheet
x = (i - 1) * 50 + 2
With shD
.Range("C3").Value = shW.Range("B2").Value
.Range("I3").Value = shW.Range("C2").Value
.Range("G6").Value = shW.Range("D2").Value
.Range("C9:L58").Value = shW.Cells(x, "F").Resize(50, 10).Value
.Range("L60").Value = "P." & i 'ページ番号 場所は適切なところを指定
.Name = getSheetName(wb, CStr(i))
End With
Next
If newFlag <> 1 Then
Application.DisplayAlerts = False
wb.SaveAs fPath & fName
Application.DisplayAlerts = True
End If
Application.ScreenUpdating = True
MsgBox "伝票ブックを作成しました"
End Sub
Sub 集計表作成(DataID As String, FromDate As String, ToDate As String, DlvCycle As String, DlvType As String)
Dim fDate As Date
Dim tDate As Date
Dim shF As Worksheet
Dim shT As Worksheet
Dim dicD As Object
Dim dicE As Object
Dim dicC As Object
Dim w As Variant
Dim c As Range
Dim dKey As Variant
Dim dInpDate As Date
Dim dCycle As String
Dim dType As String
Dim dSfx As String
Dim dNo As String
Dim dCom As String
Dim dVcnt As Long
Dim dPcs As Long
Dim dRsv As Variant
Dim dBase(1 To 7) As Variant
Dim z As Long
Dim i As Long
Dim x As Long
Dim shnAdd As String
Application.ScreenUpdating = False
If DataID = "単品" Then
Set shF = Sheets("単品データ")
Set shT = Sheets("原紙 集計表 単品")
shnAdd = "集計表 単品"
Else
Set shF = Sheets("抱合せデータ")
Set shT = Sheets("原紙 集計表 抱合せ")
shnAdd = "集計表 抱合せ"
End If
shT.Copy After:=Sheets(Sheets.Count)
Set shT = ActiveSheet
shT.Name = getSheetName(ThisWorkbook, shnAdd)
fDate = FromDate
tDate = ToDate
Set dicD = CreateObject("Scripting.Dictionary") '集計データ用
Set dicE = CreateObject("Scripting.Dictionary") '枝番管理用
Set dicC = CreateObject("Scripting.Dictionary") '商品代表行用
For Each c In shF.Range("A2", shF.Range("A" & shF.Rows.Count).End(xlUp))
dInpDate = c.Offset(, 1).Value
dCycle = c.Offset(, 2).Value
dType = c.Offset(, 3).Value
dSfx = c.Offset(, 4).Value
dNo = c.Offset(, 6).Value
dCom = c.Offset(, 8).Value
dVcnt = c.Offset(, 10).Value
dPcs = c.Offset(, 11).Value
dRsv = c.Offset(, 12).Value
dKey = dRsv & vbTab & dCom
If dInpDate >= FromDate And dInpDate <= ToDate And dCycle = DlvCycle And dType = DlvType Then
If Not dicD.exists(dKey) Then
dBase(1) = dNo
dBase(2) = dCom
dBase(5) = dRsv
dicD(dKey) = dBase
End If
If Not dicC.exists(dCom) Then dicC(dCom) = dKey
w = dicD(dKey)
If DataID = "単品" Or (Not DataID = "単品" And Not dicE.exists(dSfx)) Then w(3) = w(3) + dVcnt
dicE(dSfx) = True
w(6) = w(6) + dVcnt
w(7) = w(7) + dPcs
dicD(dKey) = w
w = dicD(dicC(dCom))
w(4) = w(4) + dPcs
dicD(dicC(dCom)) = w
End If
Next
If dicD.Count = 0 Then
MsgBox "対象データがありません"
Else
shT.UsedRange.Offset(1).ClearContents
shT.Range("A2").Resize(dicD.Count, 7).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicD.items))
shT.Cells.Sort Key1:=shT.Columns("B"), Order1:=xlAscending, Header:=xlYes
shT.Select
Application.ScreenUpdating = True
MsgBox "集計が完了しました"
End If
End Sub
Function getSheetName(wb As Workbook, shn As String) As String
Dim cnt As Long
Dim st As String
cnt = 1
st = shn
Do
If IsError(Evaluate("'[" & wb.Name & "]" & st & "'!A1")) Then Exit Do
cnt = cnt + 1
st = shn & "(" & cnt & ")"
Loop
getSheetName = st
End Function
(ぶらっと)
ぶらっと様 ありがとうございます。
>もう一度、単品、抱合せ とれぞれで、伝票枚数（代表と個別と）のカウントルールを教えて。
考え方は「個数」のカウントの仕方とほぼ同じです。 例えば「羽根布団」のデータが下記のようにあるとします。
商品コード 商品名 伝票枚数 個数 指定日 AAA 羽根布団 1 2 6/20 AAA 羽毛布団 1 1 AAA 羽毛布団 1 1 6/20 AAA 羽毛布団 1 3 AAA 羽毛布団 1 6 6月下旬 AAA 羽毛布団 1 4
↓集計後
商品コード 商品名 伝票総数 総個数 指定日 指定日別伝票数 指定日別個数 AAA 羽毛布団 6 17 AAA 羽毛布団 3 8 AAA 羽毛布団 6/20 2 3 AAA 羽毛布団 6月下旬 1 6
上記のように、商品の1行目に伝票と個数の総計、次の行から指定日別の伝票の枚数と個数のようにできると分かりやすいです。
抱合せの場合、セット商品の一番上の商品に伝票をカウントします。
商品コード 商品名 伝票枚数 個数 指定日 AAA 羽根布団 1 2 6/20 BBB 羽毛敷布 1 6/20 CCC 羽毛枕 1 6/20 ←ここまで1セット DDD 羽毛敷布ダブル 1 1 AAA 羽毛布団 1 CCC 羽毛枕 2 ←ここまで1セット AAA 羽毛布団 1 3 6/25 EEE 綿敷布 1 6/25 ←ここまで1セット
↓集計後
商品コード 商品名 伝票総数 総個数 指定日 指定日別伝票数 指定日別個数 AAA 羽毛布団 2 7 AAA 羽毛布団 1 AAA 羽毛布団 6/20 1 2 AAA 羽毛布団 6/25 1 3 BBB 羽毛敷布 2 BBB 羽毛敷布 6/20 1 BBB 羽毛敷布 6/25 1 CCC 羽毛枕 3 CCC 羽毛枕 2 CCC 羽毛枕 6/20 1 DDD 羽毛敷布ダブル 1 1 DDD 羽毛敷布ダブル 1 1 EEE 綿敷布 1 EEE 綿敷布 6/25 1
分かりにくいですがこんな感じです。
現在のコードでは伝票枚数が指定日別だけですので、各商品の一行目に合計を出していただけるとありがたいです。
（にょろ）
>ここまで1セット
抱合せの 「ここまで１セット」というくくりは、レイアウト的に言えば、そのなかに 異なる入力日、便名、区分が混在する可能性はあるけど、実際のデータとしては【枝番】が同じものは１セットということでいいのかな？
で、単品にしろ、抱合せにしろ、代表行を挿入するということをちょっと考えてみる。 ロジックがかなりかわるので少し時間がかかるかもしれない。
ところで、原紙だけど、伝票の原紙も、今回の集計表の原紙も 単品、抱合せ それぞれで準備する仕様だけど 単品と抱合せで原紙の内容はかわる？ もし、同じなら、単に 原紙 伝票 とか 原紙 集計表 という １枚でもよかったかな？と思ったりしている。
(ぶらっと)
>異なる入力日、便名、区分が混在する可能性はあるけど まずその可能性はないですが、入力ミスでそうなる可能性はあります。
>実際のデータとしては【枝番】が同じものは１セットということでいいのかな はい、そうです。
>原紙だけど、伝票の原紙も、今回の集計表の原紙も 単品、抱合せ それぞれで準備する仕様だけど 単品と抱合せで原紙の内容はかわる
いえ、変わりませんので、同じ原紙を使って構いません。
あと、印刷範囲からは外れますが、人が見た時に「この集計表はいつからいつまでの集計表か」と分かるように、
I J 2 集計日 12/6/11 ←集計を行った日 3 開始日 12/5/11 ←集計開始日 4 締め日 12/6/10 ←集計締め日
このように入れようかと思っています。（またまた後出しですみません。原紙にI列の見出しだけでも入れておこうかと…） ※下記のようなレイアウトでも構いません。やりやすい方で… I J K L M N 2 集計日 12/6/11 開始日 12/5/11 締め日 12/6/10
よろしくお願いいたします
（にょろ）
もう１つ。
ずっと気になっていたんだけど、単品であれ、抱合せであれ入力シートのK列の伝票枚数。 ここは、1(抱合せのセットではセット全体で1)に決まっているのでは？ なぜ、伝票枚数という列があるんだろう？もし、単品であれ抱合せであれ、ここに、たとえば 5 と入ると 伝票が 5枚ということ？ もしそうなら、それは具体的にはどんな状況なんだろう？
(ぶらっと)
>ここは、1(抱合せのセットではセット全体で1)に決まっているのでは？
実は私も入力された生データを見たことがないので説明を聞いただけですが、商品の数が多い場合に1枚の伝票に入りきらずに 複数枚の伝票にわたることがあるようです。 特に抱合せ商品の場合は2～3枚になったりすることがよくあるようなので「枚数」というカウントがあります。 単品の場合も何かの事情によって伝票が複数枚できる可能性はあるので、おっしゃるように「5」と入ると 伝票は「5枚」とカウントします。 （例えば同じ商品を複数の宛先に送る場合など）
（にょろ）
↑ 伝票枚数については了解。
代表行挿入、追加仕様反映のコードを今から書き始める。 とりあえず、そちらの要件をベースに書いてみるけど、私の理解が間違っていなければ以下のような状態。 実際には入力データは、もっと何種類もあるわけだけど「データモデル」として、かりに２行だけだったとして。
(単品） 枝番 商品名 伝票枚数 個数 ＡＡ １ １０ ＢＢ １ ２０
(抱合せ) 枝番 商品名 伝票枚数 個数 ００１ ＡＡ １ １０ ００１ ＢＢ ２０
これら、いずれも集計表では
商品名 伝票総数 総個数 指定日別伝票枚数 指定日別個数 ＡＡ １ １０ ＜－挿入行 ＡＡ １ １０ ＜－入力データ集計行 ＢＢ １ ２０ ＜－挿入行 ＢＢ １ ２０ ＜－入力データ集計行
このようになると理解している。感想としては ・自分が閲覧者であれば、もともと２行の表をなぜ４行にするんだ、見づらいじゃないか？ と、文句を言いそう。 ・抱合せの場合、実際には伝票枚数は１枚だけど、集計表の伝票枚数列を合計して、２枚と誤解してしまいそう。
(ぶらっと)
自信度、６５％ぐらいだけど、とりあえず試してみて。 なお、原紙 は "原紙 集計表" として１つにまとめた。 また、集計日、開始日、締日は 見出しをＩ列、各日付をＪ列にしている。
Sub 集計表作成(DataID As String, FromDate As String, ToDate As String, DlvCycle As String, DlvType As String)
Dim fDate As Date
Dim tDate As Date
Dim shF As Worksheet
Dim shT As Worksheet
Dim dicD As Object
Dim dicE As Object
Dim w As Variant
Dim c As Range
Dim dKey0 As String
Dim dKey1 As String
Dim dInpDate As Date
Dim dCycle As String
Dim dType As String
Dim dSfx As String
Dim dNo As String
Dim dCom As String
Dim dVcnt As Long
Dim dPcs As Long
Dim dRsv As Variant
Dim dBase(1 To 7) As Variant
Dim z As Long
Dim i As Long
Dim x As Long
Dim shnAdd As String
Application.ScreenUpdating = False
If DataID = "単品" Then
Set shF = Sheets("単品データ")
shnAdd = "集計表 単品"
Else
Set shF = Sheets("抱合せデータ")
shnAdd = "集計表 抱合せ"
End If
Set shT = Sheets("原紙 集計表")
shT.Copy After:=Sheets(Sheets.Count)
Set shT = ActiveSheet
shT.Name = getSheetName(ThisWorkbook, shnAdd)
fDate = FromDate
tDate = ToDate
Set dicD = CreateObject("Scripting.Dictionary") '集計データ用
Set dicE = CreateObject("Scripting.Dictionary") '枝番管理用
For Each c In shF.Range("A2", shF.Range("A" & shF.Rows.Count).End(xlUp))
dInpDate = c.Offset(, 1).Value
dCycle = c.Offset(, 2).Value
dType = c.Offset(, 3).Value
dSfx = c.Offset(, 4).Value
dNo = c.Offset(, 6).Value
dCom = c.Offset(, 8).Value
dVcnt = c.Offset(, 10).Value
dPcs = c.Offset(, 11).Value
dRsv = c.Offset(, 12).Value
dKey0 = 0 & dCom
dKey1 = 1 & dRsv & vbTab & dCom
If dInpDate >= FromDate And dInpDate <= ToDate And dCycle = DlvCycle And dType = DlvType Then
If Not dicD.exists(dKey0) Then
dBase(1) = dNo
dBase(2) = dCom
dBase(5) = ""
dicD(dKey0) = dBase
End If
If Not dicD.exists(dKey1) Then
dBase(1) = dNo
dBase(2) = dCom
dBase(5) = dRsv
dicD(dKey1) = dBase
End If
If Not dicE.exists(dSfx) Then
dicE(dSfx) = dVcnt
End If
If DataID = "抱合せ" Then dVcnt = dicE(dSfx)
w = dicD(dKey0)
w(3) = w(3) + dVcnt
w(4) = w(4) + dPcs
dicD(dKey0) = w
w = dicD(dKey1)
w(6) = w(6) + dVcnt
w(7) = w(7) + dPcs
dicD(dKey1) = w
End If
Next
If dicD.Count = 0 Then
MsgBox "対象データがありません"
Else
With shT
Intersect(.UsedRange, .Columns("A:G")).Offset(1).ClearContents
.Range("J1").Value = Date
.Range("J2").Value = FromDate
.Range("J3").Value = ToDate
.Range("A2").Resize(dicD.Count, 7).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicD.items))
.Cells.Resize(, 7).Sort Key1:=shT.Columns("B"), Order1:=xlAscending, Header:=xlYes
.Select
Application.ScreenUpdating = True
MsgBox "集計が完了しました"
End With
End If
End Sub
(ぶらっと)
ぶらっと様ありがとうございます
抱合せの伝票枚数ですが、前トピに書きましたように枝番の最初の商品にのみ伝票が記載され、それをカウントします
>上記のデータでは枝番「001」のデータは、伝票1枚で3種類の商品を出荷しています。 >なので集計は > （5月28日の集計） > A B C D E F > No 商品名 伝票枚数 個数 指定日 指定日毎個数 > 030 羽毛布団 1 1 5月30日 1 > 031 羽毛枕 1 5 6月1日 5 > 031 羽毛枕 0 1 5月30日 1 > 035 敷布 0 2 5月30日 2 > のように伝票枚数は「枝番」の最初の商品にのみカウントされ、同じ枝番の別の商品にはカウントされません。
教えていただいたコードを今からテストします。
（にょろ）
>伝票枚数は「枝番」の最初の商品にのみカウントされ、同じ枝番の別の商品にはカウントされません。
なるほど。あらかじめ言っておくと、アップしたコードではそうなっていない。 あくまで、伝票枚数を、枝番最初の行のものから持ってくるだけで、その枝番内のすべての行が、その最初の行の伝票枚数を持っているというロジックになっている。
ほかのところが確認されれば、最終的にそこを直そうね。
追記）
枝番の最初の行の商品にのみ伝票枚数反映ということについては、そちらの事務処理要件で、 こちらが、どうこういう話ではないけど、商品と指定日で集約する集約表を見た場合
枝番 商品 伝票枚数 指定日 ００１ ＡＡ １ ６月下旬 ００１ ＢＢ ６月下旬 ００２ ＡＡ １ ６月下旬 ００２ ＢＢ ６月下旬
このようにあったら集約表が
商品 伝票枚数 指定日 ＡＡ ２ ６月下旬 ＢＢ ６月下旬
もし、入力表に記入する順番が異なっていて
枝番 商品 伝票枚数 指定日 ００１ ＢＢ １ ６月下旬 ００１ ＡＡ ６月下旬 ００２ ＡＡ １ ６月下旬 ００２ ＢＢ ６月下旬
このようにあったら集約表が
商品 伝票枚数 指定日 ＡＡ １ ６月下旬 ＢＢ １ ６月下旬
こうなるんだよねぇ。一般的には、なんだかへんだなぁとは思うけどね。
(ぶらっと)
>一般的には、なんだかへんだなぁとは思うけどね 私もそう思ったので、それでいいのか確認しましたが、それで大丈夫だということでした。
あと、もしできれば、「合計」の行が分かりやすいように文字を自動的に太字にするとかした方がいいかなあと できた集計表を見て思いました。 おっしゃるように何か見にくいので…
（にょろ）
枝番最初の商品にのみ伝票枚数反映を組み込んだ。 なお、「合計」の行が分かりやすいように文字を自動的に太字 についてはコード対応ではなく 以下で逃げない？
・原紙 集約表 の A2:G● まで選択。（●はできあがる集約表の最大行数を想定して充分に大きな行まで） ・条件付き書式 「数式が」 =$B2<>$B1 で、書式でフォントを太字
Sub 集計表作成(DataID As String, FromDate As String, ToDate As String, DlvCycle As String, DlvType As String)
Dim fDate As Date
Dim tDate As Date
Dim shF As Worksheet
Dim shT As Worksheet
Dim dicD As Object
Dim dicE As Object
Dim w As Variant
Dim c As Range
Dim dKey0 As String
Dim dKey1 As String
Dim dInpDate As Date
Dim dCycle As String
Dim dType As String
Dim dSfx As String
Dim dNo As String
Dim dCom As String
Dim dVcnt As Long
Dim dPcs As Long
Dim dRsv As Variant
Dim dBase(1 To 7) As Variant
Dim z As Long
Dim i As Long
Dim x As Long
Dim shnAdd As String
Application.ScreenUpdating = False
If DataID = "単品" Then
Set shF = Sheets("単品データ")
shnAdd = "集計表 単品"
Else
Set shF = Sheets("抱合せデータ")
shnAdd = "集計表 抱合せ"
End If
Set shT = Sheets("原紙 集計表")
shT.Copy After:=Sheets(Sheets.Count)
Set shT = ActiveSheet
shT.Name = getSheetName(ThisWorkbook, shnAdd)
fDate = FromDate
tDate = ToDate
Set dicD = CreateObject("Scripting.Dictionary") '集計データ用
Set dicE = CreateObject("Scripting.Dictionary") '枝番管理用
For Each c In shF.Range("A2", shF.Range("A" & shF.Rows.Count).End(xlUp))
dInpDate = c.Offset(, 1).Value
dCycle = c.Offset(, 2).Value
dType = c.Offset(, 3).Value
dSfx = c.Offset(, 4).Value
dNo = c.Offset(, 6).Value
dCom = c.Offset(, 8).Value
dVcnt = c.Offset(, 10).Value
dPcs = c.Offset(, 11).Value
dRsv = c.Offset(, 12).Value
dKey0 = 0 & dCom
dKey1 = 1 & dRsv & vbTab & dCom
If dInpDate >= FromDate And dInpDate <= ToDate And dCycle = DlvCycle And dType = DlvType Then
If Not dicD.exists(dKey0) Then
dBase(1) = dNo
dBase(2) = dCom
dBase(5) = ""
dicD(dKey0) = dBase
End If
If Not dicD.exists(dKey1) Then
dBase(1) = dNo
dBase(2) = dCom
dBase(5) = dRsv
dicD(dKey1) = dBase
End If
If DataID = "抱合せ" And dicE.exists(dSfx) Then dVcnt = 0
dicE(dSfx) = True
w = dicD(dKey0)
If dVcnt <> 0 Then w(3) = w(3) + dVcnt
w(4) = w(4) + dPcs
dicD(dKey0) = w
w = dicD(dKey1)
If dVcnt <> 0 Then w(6) = w(6) + dVcnt
w(7) = w(7) + dPcs
dicD(dKey1) = w
End If
Next
If dicD.Count = 0 Then
MsgBox "対象データがありません"
Else
With shT
Intersect(.UsedRange, .Columns("A:G")).Offset(1).ClearContents
.Range("J1").Value = Date
.Range("J2").Value = FromDate
.Range("J3").Value = ToDate
.Range("A2").Resize(dicD.Count, 7).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicD.items))
.Cells.Resize(, 7).Sort Key1:=shT.Columns("B"), Order1:=xlAscending, Header:=xlYes
.Select
Application.ScreenUpdating = True
MsgBox "集計が完了しました"
End With
End If
End Sub
(ぶらっと)
ぶらっと様ありがとうございます！
データが実際に何行ぐらいできるのか分からないので多めに条件付き書式を設定したら処理がやたら重くなってしまいましたが、 集計はうまくいきました。
重いと言われたら実際のデータ行の目安を聞いて対応してみます。
ありがとうございました！
（にょろ）
すみません、一点お教えください…
私の環境がWindows7/Excel2007なのですが、WindowsXP/Excel2003を使っている人が別の営業所にいるということで 元のブックの拡張子を.xls(97-2003互換モード)にして保存しましたが、伝票ブックを作成する際に 「コンパイルエラー 変数が定義されていません」 というエラーが出ると報告を受けました。 私の想像で、伝票ブックを「.xlsm」で作成しようとしてエラーになったのだと思い、伝票作成モジュールを 下記のように変更しました
fName = Format(CDate(shW.Range("B2").Value), "yymmdd") & "_" & DataID & ".xls" '拡張子を「.xls」に
If newFlag = 2 Then wb.SaveAs fPath & fName 'xlOpenXMLWorkbookMacroEnabled を削除
何しろ手元にExcel2003の環境がないのでこれで大丈夫なのか不安なのですが、このような修正で大丈夫でしょうか？
（にょろ）
2003環境でも実行するなら、そちらで対応したように ブックをすべて .xls にするのは正しい。 ただし、「コンパイルエラー 変数が定義されていません」このエラーは、そういうことではなく、純粋にコード内で使われている変数が定義されていないというもの。 基本的にこちらでアップしたコードは変数定義の漏れはないんだけど そちらで、ユーザーフォームに組み込んで動かしているコードに未定義の変数があるということだと思う。
その変数の定義がないとのエラー時、どのコードなのか、その変数は何だったのかがわかるはずなので、それを確認してみたらどうかな？
(ぶらっと)
↑ あぁ、未定義となったのは xlOpenXMLWorkbookMacroEnabled だったのかな？ それであれば、そちらでこれを削除した対応でＯＫ。
(ぶらっと)
ぶらっと様
＞あぁ、未定義となったのは xlOpenXMLWorkbookMacroEnabled だったのかな？ はい、そうです。ここが反転していたようです。
これでよかったんですね。 ありがとうございます。
（にょろ）
祝！！ 掲示板復旧。
ピッキングリストに取り掛かっている。前触れでいくつか。
・処理の流れとしては 抽出（在庫ノンチェック）--> 商品単位に○×設定し作業シートに記入 １）この作業シートをベースに伝票作成（ここはアップ済みのものとかわらない） ２）並行して、この作業シートをベースに、明細単位の引当と在庫表更新 --> ピッキングリストの作成 ・なので、もちろん、各処理を別々に行えるところは行ってもいいけど、考え方としては伝票作成処理で 明細引当とピッキングリスト作成を一連で行う流れ。 ・伝票については同じものがフォルダにあれば、それに追加するのか、それとは別に新規で作成するのか という制御をいれたけど、ピッキングリストは、手を抜いて、常に、作業シートにあるもののみで 作成する。かつ、新規ブックとして作成して、とりあえず、そのままエクセル画面に残しておくので 操作で保存するなり、マクロで保存追加するなり、そこは、そちらでやってもらおうと思っている。
ところで、ピッキングリストのレイアウトは、まだ精査していないけど、○が付いたものだけを引き当てている。 なのに、そちらがアップしたサンプルでは、○×欄があるね？ そもそも商品として引き当てができなかった ものに対して、×の明細って何を表示するんだろうか？
なので、今、考えているピッキングリストは ○のものだけ。
ただ、今度は、（今度も？）コード完成までには時間がかかりそう。
(ぶらっと)
ぶらっと様ありがとうございます。
＞なのに、そちらがアップしたサンプルでは、○×欄があるね 私もそれが謎だったので確認したのですが「手書きする部分だから考慮に入れなくていい」ということでした。 別の処理に使うものなのかも…
＞ ただ、今度は、（今度も？）コード完成までには時間がかかりそう。
了解いたしました。申し訳ございません…
（にょろ）
自信度４５％ぐらい（はなはだ弱気）
前触れでも少しふれたけど、 基本的な考え方としては、一連の処理で抽出から伝票作成-、ピッキングリストを続けて処理。 もちろん、それぞれ、個別に順次、処理していくこともできないことはないので、もし、そのような要望があれば 具体的に要求してくれる？
また、これも先にレスしたようにピッキングリストは新規ブックとして作る。今のところ保存はしていない。 それと、ピッキングリスト、例によって原紙を作っておいてね。"原紙 ピッキング"
で、今までアップしたもののなかで、集約表は単独の別物なので今回はさわっていない。 また共通プロシジャのgetSheetNameおよび伝票作成プロシジャも変更なし。
抽出プロシジャは、中途半端に引当実行したものが最新バージョンだと思うけど、もとに戻した。 一応以下に最新版を。中途半端にアップしてある引当プロシジャは削除してね。
で、そちらのモジュールが１つなのか複数に分けているのかわからないんだけど、 どの標準モジュールでもいいので、モジュールの先頭の宣言部に
Enum Inventry
fnInitial
fnAllocTot
fnAllocDtl
fnPickLst
fnEnd
End Enum
で、以下にアップするプロシジャを新設。（抽出はリバイス）
これらは実際には
Sub Test0()
'以下ではコンスタントで抽出キーを与えているが、実際には cSyubetu.Value や tDate.Value を使う。
Call 伝票関連処理("抱合せ", "2012/5/28", "3便", "通常")
End Sub
こんなコードで実行する。
Sub 伝票関連処理(DataId As String, OutDate As String, DlvCycle As String, DlvType As String)
Dim rtn As Long
Call 抽出(DataId, OutDate, DlvCycle, DlvType)
If Not 商品IO(fnInitial) Then Exit Sub
Call 商品IO(fnAllocTot, DataId)
Call 伝票作成(DataId)
Call 商品IO(fnAllocDtl, DataId, DlvCycle, DlvType)
Call 商品IO(fnPickLst, DataId, DlvCycle)
Call 商品IO(fnEnd)
End Sub
Function 抽出(DataId As String, OutDate As String, DlvCycle As String, DlvType As String) As Long
'引数は全てテキストボックスや、コンボボックス入力を想定して文字列
'DataID "単品" かそれ以外か
'OutDate 文字列で "2012/5/10" 等 日付型として受け入れられる型式
'DlvCycle 1便、2便 等
'DlvType 通常、至急 等
'戻り値は抽出データ件数
Dim sh As Worksheet
Application.ScreenUpdating = False
If DataId = "単品" Then
Set sh = Sheets("単品データ")
Else
Set sh = Sheets("抱合せデータ")
End If
With Sheets("作業") '抽出用作業シート
.Cells.ClearContents
.Range("Q1:S1").Value = sh.Range("B1:D1").Value
.Range("Q2").Value = CDate(OutDate)
.Range("R2").Value = DlvCycle
.Range("S2").Value = DlvType
sh.Columns("A:O").AdvancedFilter xlFilterCopy, .Range("Q1").CurrentRegion, .Range("A1")
.Range("Q1").CurrentRegion.Clear
抽出 = .UsedRange.Rows.Count - 1
End With
Application.ScreenUpdating = True
End Function
Function 商品IO(fn As Long, Optional DataId As String, Optional DlvCycle As String, Optional DlvType As String) As Boolean
'fn fnInitial 在庫表情報の取り込み等
' fnAllocTot 商品別総量をベースに可否判定 --> 作業シートの可否欄設定
' fnAllocDtl 引当○のものに対し、エリア、棚ごとに実引当、在庫表更新
' fnPickLst ピッキングリストの作成
' fnEnd 終了処理
'DataId fnAllocTot,fnAllocDtl,fnPicLst時のみ必要
'DlvCycle,DlvType fnAllocDtl時必要（在庫表の履歴タイトル用）
'DlbCycle fnPicLst時もこれは必要。印字用。
Const FinalInv As String = "R" '最終在庫列 列記号
Static dicZ As Object
Static dicD As Object
Static lstRow As Long
Static colZ As Long
Static sv As Variant
Dim shW As Worksheet
Dim shZ As Worksheet
Dim w As Variant
Dim dKey As Variant
Dim com As Variant
Dim qty As Long
Dim loc As String
Dim locSub As String
Dim zone As String
Dim c As Range
Dim f As Long
Dim t As Long
Dim i As Long
Dim x As Long
Dim b As Long
Dim okFlag As Boolean
Dim picWB As Workbook
Dim picSh As Worksheet
Set shW = ThisWorkbook.Sheets("作業")
Set shZ = ThisWorkbook.Sheets("在庫表")
Select Case fn
Case fnInitial
lstRow = shW.Range("B" & shW.Rows.Count).End(xlUp).Row
If lstRow = 1 Then
MsgBox "データが抽出されていません"
Exit Function
End If
If Len(shZ.Cells(2, shZ.Columns.Count).Value) > 0 Then
MsgBox "在庫表の出荷履歴が満杯で、引当情報を記入することができません"
Exit Function
Else
colZ = shZ.Cells(2, shZ.Columns.Count).End(xlToLeft).Column + 1 '履歴セット列
End If
Set dicZ = CreateObject("Scripting.Dictionary") '商品毎
Set dicD = CreateObject("Scripting.Dictionary") '明細管理用
sv = shW.Range("E2").Resize(lstRow - 1).Value
'対象の作業表にある商品を格納
For Each c In shW.Range("G2", shW.Range("G" & shW.Rows.Count).End(xlUp))
dicZ(c.Value) = 0
Next
'格納した商品に関し、在庫表から、その行番号と引き当て可能数量を取り込み
For Each c In shZ.Range("G3", shZ.Range("G" & shZ.Rows.Count).End(xlUp))
With c.EntireRow
com = c.Value
qty = .Range(FinalInv & 1).Value
loc = .Range("D1").Value
locSub = .Range("E1").Value
zone = .Range("F1").Value
End With
If qty > 0 Then
If dicZ.exists(com) Then
If Not dicD.exists(com) Then Set dicD(com) = CreateObject("Scripting.Dictionary")
dicZ(com) = dicZ(com) + qty
dKey = Join(Array(c.Value, loc, locSub, zone), vbTab)
If Not dicD(com).exists(dKey) Then dicD(com)(dKey) = Array(0, 0, 0)
w = dicD(com)(dKey)
w(0) = c.Row
w(1) = qty
dicD(com)(dKey) = w
End If
End If
Next
Case fnAllocTot
Application.ScreenUpdating = False
'単品なら引当ロジックのため枝番を各行ユニークに
If DataId = "単品" Then
shW.Range("E2").Value = 1
shW.Range("E2").Resize(lstRow - 1).DataSeries
End If
f = 2
For i = 2 To lstRow
t = i
If shW.Cells(i, "E").Value <> shW.Cells(i + 1, "E").Value Then
okFlag = True
For x = f To t
com = shW.Cells(x, "G").Value
qty = shW.Cells(x, "L").Value
If dicZ(com) > qty + 2 Then
dicZ(com) = dicZ(com) - qty
Else
okFlag = False
End If
If Not okFlag Then Exit For
Next
shW.Cells(f, "F").Resize(t - f + 1).Value = IIf(okFlag, "○", "×")
f = i + 1
End If
Next
Application.ScreenUpdating = True
Case fnAllocDtl
Application.ScreenUpdating = False
shZ.Cells(2, colZ).Value = DataId & DlvCycle & DlvType
For Each c In shW.Range("G2", shW.Range("G" & shW.Rows.Count).End(xlUp))
With c.EntireRow
qty = .Range("L1").Value
com = .Range("G1").Value
okFlag = .Range("F1").Value = "○"
End With
If okFlag Then
For Each dKey In dicD(com)
w = dicD(com)(dKey)
b = w(1) - w(2)
If b >= qty Then
w(2) = w(2) + qty
qty = 0
Else
qty = qty - b
w(2) = w(1)
End If
dicD(com)(dKey) = w
shZ.Cells(w(0), colZ).Value = w(2)
If qty = 0 Then Exit For
Next
End If
Next
Application.ScreenUpdating = True
Case fnPickLst
Application.ScreenUpdating = False
Sheets("原紙 ピッキング").Copy
Set picWB = ActiveWorkbook
Set picSh = ActiveSheet
With picSh
.Range("E5").Value = DataId
.Range("J3").Value = DlvCycle
.Range("H5").Value = WorksheetFunction.Sum(shW.Columns("K"))
i = 10
For Each com In dicD
For Each dKey In dicD(com)
w = Split(dKey, vbTab)
com = w(0)
loc = w(1)
locSub = w(2)
zone = w(3)
w = dicD(com)(dKey)
qty = w(2)
If qty > 0 Then
.Cells(i, "D").Value = shZ.Cells(w(0), "F").Value
.Cells(i, "E").Value = zone
.Cells(i, "F").Value = loc
.Cells(i, "G").Value = locSub
.Cells(i, "H").Value = com
.Cells(i, "I").Value = shZ.Cells(w(0), "I").Value
.Cells(i, "J").Value = shZ.Cells(w(0), "J").Value
.Cells(i, "L").Value = qty
i = i + 1
End If
Next
Next
End With
Application.ScreenUpdating = True
Case fnEnd
shW.Range("E2").Resize(lstRow - 1).Value = sv
Set dicZ = Nothing
Set dicD = Nothing
Set shW = Nothing
Set shZ = Nothing
Set picWB = Nothing
Set picSh = Nothing
End Select
商品IO = True
End Function
(ぶらっと)
ぶらっと様ありがとうございます。
テストしてみましたが、在庫の有無にかかわらず
Function 商品IO プロシージャの
Sheets("原紙 ピッキング").Copy
この部分で「インデックスが有効範囲にありません」のエラーになります。 雛形シートの名前は上記をコピーしているので間違いはないはずなんですが…
伝票ブックは作成されます。
（にょろ）
ごめん、ごめん。
ThisWorkbook.Sheets("原紙 ピッキング").Copy
こうしてくれる？
(ぶらっと)
ありがとうございます。
ピッキングリストまで作成はされたのですが…
①ピッキング日時が入らない（日付も時間も） ②伝票枚数が、伝票ブックのものの（引当て不可のものも含めた）枚数になっている ③エリア・棚・枝番・エリア色が正しく転記されない 例） 元のマスタ C D E F エリア 棚 枝番 エリア色 D 1 2 緑
作成されたピッキングリスト D E F G エリア色 エリア 棚 枝番 緑 緑 1 1
このようになります。
（にょろ）
>①ピッキング日時が入らない（日付も時間も）
うん、いれていない。 ちなみに、明細行以外で入れているところは、
.Range("E5").Value = DataId
.Range("J3").Value = DlvCycle
.Range("H5").Value = WorksheetFunction.Sum(shW.Columns("K"))
この３行だけ。 ほかにも必要なら、どこから持ってくるかを提示お願い。
(ピッキング日時って、実際にピッキング処理をしたときにピッカーが記入するんじゃないの？ それとも、ピッキングリスト作成時点の日時でいいの？）
> ②伝票枚数が、伝票ブックのものの（引当て不可のものも含めた）枚数になっている
うん、そうしている。
というか、よくわからなかったので、
.Range("H5").Value = WorksheetFunction.Sum(shW.Columns("K"))
このように、抽出された作業シートの伝票枚数列を単純に合計しているだけ。
(その元ネタはデータシート）
○がついた行の伝票枚数だけの合計にしたらいいのかな？
（ここで、例の枝番がらみの伝票枚数カウントロジックを働かせるのは大変になるので）
>③エリア・棚・枝番・エリア色が正しく転記されない
こちらでは枝番は正しいけどなぁ？ エリアは確かに間違っていた。 IO商品の Case fnInitial のブロックの真ん中あたりに
With c.EntireRow
com = c.Value
qty = .Range(FinalInv & 1).Value
loc = .Range("D1").Value
locSub = .Range("E1").Value
zone = .Range("F1").Value
End With
この zone = .Range("F1").Value これを zone = .Range("C1").Value に修正。
①、②、③の確認お願いね。
(ぶらっと)
今回のテーマではないけど、↑でコメントした
>（ここで、例の枝番がらみの伝票枚数カウントロジックを働かせるのは大変になるので）
これで、はたと気が付いた。 集計表で伝票枚数を表示しているわけだけど、それは、元ネタの入力シートから集計しているので 引当可否は考慮していないよ。なので、実際の伝票枚数とは違っている公算大だね。
(ぶらっと)
ついでにといっては何だけど、自分が書いているコードの意味を理解するために以下メモ。 時間があればレスもらえればうれしい。
１．まず、そちらのコードで最初の入力データシート（"単品データ"、"抱合せデータ”の各シート）が できあがるわけだけど、これは、【出荷予定情報】を前もって登録しておくものだと理解。 ２．で、その中から、実際の出荷業務として、"抽出"機能があって、ここで、当該出荷（ないしは出庫作業）の作業バッチを組む。 ３．その作業バッチである"作業"シートのデータに対して、引当可能かどうかを判定し、○×設定。 ４．○×が設定された"作業"シートの内容を、ただただ淡々と、"伝票作成"で、伝票ブックを作成。 ５．これとは並列で、○のものにつき、エリア、棚、枝 別の実在庫を引当、ピッキングリストを作成する。
まぁ、こんな流れだと理解している。
Ａ．入力データシートのＫ列の伝票枚数。これは、担当者が生うちしているのか、なんらかのロジックで 設定されているのか不明だけど、この伝票は"入庫伝票"ではなく、"出庫伝票" だよね？ Ｂ．一方、"伝票作成"で作成している伝票がある。これは"出庫伝票"だと理解しているけど Ａ．のＫ列にある伝票枚数と関連している？ロジックとしては、Ｋ列の値が何であれ、それは無視して 淡々と必要な行数を５０行を１シートにして作成している。ここで作成されたブック（シート）と Ａ．のＫ列の伝票枚数との関係ってどうなっているんだろう？ Ｃ．運用としてわからないことはまだまだ多いんだけど、たとえば、×でも伝票は作成する。 一方、引当は○のものだけを相手にする。そうすると、当然○のものは引き当て可能在庫が減少。 （いずれ実際に出荷されれば在庫その門が減少するはずだけど） だけど、×のものはどうなるかというと、ほおっておくはずはなく、いずれ在庫補充がされたら 引き当てを行いピッキングリストを作成して現場が出庫作業をするはずだよね。 この時、現在、コードで準備されている機能を使い、×で、その後補充されたものを、どのように 処理していくことになるんだろうか？
(ぶらっと)
ぶらっと様
ありがとうございます。 エリア～枝番の部分、ちゃんと入りました（枝番は私が見るところを間違えていました…）
＞ (ピッキング日時って、実際にピッキング処理をしたときにピッカーが記入するんじゃないの？ ＞ それとも、ピッキングリスト作成時点の日時でいいの？） ピッキングリスト作成時点の日時でいいです。 今はJ5に「○月○日」、L5に「00:00」で表示していますが、ここを結合してJ5にまとめて「○月○日 00:00」 と表示しても問題ないです。
＞②○がついた行の伝票枚数だけの合計にしたらいいのかな？ はい、そうです… ややこしくてすみません…
あと、以前書いたものですが、 *** ＞もとのR～AH列に履歴を書くようになっていたものではセルに色がつけられたり罫線が設定されていたり ＞したのですが、ここは最初からある程度の列まで書式を設定しておく方がよろしいでしょうか？ ＞あるいはS列だけ設定しておいてT列以降はS列の書式をコピーするとかの方がよいのでしょうか…
＞>あるいはS列だけ設定しておいてT列以降はS列の書式をコピーするとかの方がよいのでしょうか… ＞ そのほうがいいかな？ コード対応は難しくないので。 ***
この部分はまだ対応されていないということでよろしいでしょうか。 書式がコピーされないので…
最後の１～５はだいたいおっしゃる通りです。 ＞【出荷予定情報】を前もって登録しておくものだと理解 入力者が、伝票が来た時点でひたすら「出荷予定」を入力していき、そこから伝票作成（抽出）＆○×判定、 引当て可能なもののみピッキングリスト作成…という感じです。
＞ Ａ．入力データシートのＫ列の伝票枚数。これは、担当者が生うちしているのか、なんらかのロジックで ＞ 設定されているのか不明だけど、この伝票は"入庫伝票"ではなく、"出庫伝票" だよね？ はい。ユーザーフォームで伝票の内容をデータシートに転記する際に入力するもので、出庫の伝票です。
＞Ｂここで作成されたブック（シート）とＡ．のＫ列の伝票枚数との関係ってどうなっているんだろう？ データシートはあくまでも私が勝手に作ったもので（データ抽出がしやすいように）、本来は伝票シートの 伝票枚数だけをユーザーは見ています。 なのでデータシートの伝票枚数と伝票シートの伝票枚数は同じです。
Cについてですが、今回はまだ対応を要求されていないのですが在庫シートのL～P列に入庫数を入力する項目があります。 在庫不足であったものは入庫があった時点で再度伝票を作成→ピッキングリストを作成、ということになると思います。 その時の「前回"×"であったかどうか」をどう判定するかは（例えば「出庫予定」のフラグをどこかに入れておくとか） これから確認します。
（にょろ）
とりいそぎ以下で試してみて。テストしてないのでバグあれば指摘乞う。
・ピッキングリストへの日時表示
まず、原紙の当該セルの表示書式は適切なものにしておいてね。
IO商品の Case fnPickLst の
With picSh
.Range("E5").Value = DataId
.Range("J3").Value = DlvCycle
.Range("H5").Value = WorksheetFunction.Sum(shW.Columns("K"))
この下に以下を追加。
.Range("J5").Value = Date
.Range("L5").Value = Time
・在庫表引当履歴の書式反映
IO商品の Case fnAllocDtl の shZ.Cells(w(0), colZ).Value = w(2) の下に
shZ.Cells(w(0), FinalInv).Offset(, 1).Copy
shZ.Cells(w(0), colZ).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
(ぶらっと)
ぶらっと様ありがとうございます。
早速テストしました。
ですが、ピッキングリストの伝票枚数がまだ元の枚数（ピッキングできなかった伝票含めた枚数）のままです…
あと２点追加とこちらの補足不足がありました。
１．在庫表の出荷履歴の書式ですが、現在「出荷数」が入ったセルの罫線だけが前の列のものをコピーされていますが、 列全体の書式（セルの色含む）をコピーすることはできますか？
２．ピッキングリストの名前が「原紙 ピッキング」のままなので、伝票作成時と同様に「日付+区分+便名」 （同じシート名があったら(2)とつける感じで）にできますでしょうか？
長くなりましたので次トピ立てました
すみません、よろしくお願いいたします。
（にょろ）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.