[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『入荷日または使用期限の古いものを抽出』（雪だるま）
Excel2007です。
ある食品購入者向けダイレクトメールやパンフレットなどのセット作業をするための指示書を作成する業務があります。
まず下記のような入荷マスターがあります。
A B C D E F G H I 1 入荷ID 入荷日 在庫ID 品名 入荷予定数 入荷実数 使用期限（年） 使用期限（月） 使用期限（日）
入荷IDはユニークですが、在庫IDは重複しているものが多数あります。 またこのマスターは入荷IDの昇順にならんでいて、使用期限はバラバラです。 使用期限が無いものもあり、の商品には使用期限欄に「*」が入っています。
そこに顧客から「在庫ID：AAA01を1枚、AAA02を1枚、BBB01を1枚を1セットとしたダイレクトメールを2万セット作ってくれ」という依頼が来ます。
それを受けてこちらが下記のような作業指示書を作成して作業場に渡します。
「投入表」
A B C D ～ 1 業務No：○○ 2 セット数：20000 : 11 作業場 ① ② ③ ～ 12 分類 梱包物 部品 部品 ～ 13 品名 封筒A お歳暮ビラ カタログA ～ 14 在庫ID AAA01 AAA02 BBB01 ～ 15 入荷日 11/11/1 11/11/20 11/11/10 ～ 16 使用期限 12/3/20 12/1/10 12/2/20 ～ ： ： ： ： ：
1行目から14行目までは手入力です。 何がしたいかというと、14行目の「在庫ID」を入力した時、15行目・16行目の「入荷日」「使用期限」がマスターから自動的に出るようにしたいのです。 使用期限が入っているものは使用期限の古いものを抽出、入っていないものは入荷日の古いものを抽出、 もしセット数に必要な数がF列の「入荷実数」で足りなくなった場合、同じ在庫IDで次に使用期限または入荷日が古いものから使う、という感じです。 （その場合は17行目以降に次の商品の入荷日と使用期限を追加） 使用期限のあるものとないものでマスターを分けてもいいとのことです
当方マクロの知識がほとんどありません。 このようなことを関数ではできませんでしょうか？
関数じゃ無理そうなのでここや他のサイトを参考にVBAの考え方だけを書いてみました。 使用期限のあるものとないものにマスターをわけたとして、使用期限のあるものからの抽出の場合 マスターのJ列に「使用期限年月日」（G～I列）を結合したセルを作成
Dim i 'カウンタ変数 Dim j 'カウンタ変数 Dim s1 '使用期限を格納する変数1 Dim s2 '使用期限を格納する変数2 Dim kigen '最終的に出力される使用期限
For i = A2 To A列の最後まで
For j = A2 To A列の最後まで
If 「投入表」B14 = Range("C" & j) Then
s1 = ("J" & j)
End If
Next j
If 「投入表」B14 = Range("C" & i) Then
s2 = ("J" & i)
If s1 <= s2
kigen = s1
Else
kigen = s2
End If
End If
Next i
記述の仕方が分からなくてあちこち変ですがこんな考え方ではやっぱりおかしいですか？
今日1日かかってこれだけしか考えつきませんでした…
（雪だるま）
上手く行くかな？
>使用期限のあるものとないものでマスターを分けてもいいとのことです マスタは分ずに使用します
>1行目から14行目までは手入力です。 全て入力してから、マクロを実行して下さい
以下を標準モジュールに記述して下さい
Option Explicit
Public Sub Sample()
Dim i As Long
Dim j As Long
Dim k As Long
Dim lngRows As Long
Dim lngColumns As Long
Dim rngList As Range
Dim rngResult As Range
Dim vntData As Variant
Dim vntSets As Variant
Dim lngCount As Long
Dim vntStockID As Variant
Dim vntResult As Variant
Dim lngMax As Long
Dim strProm As String
'入荷マスターListの先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngList = Worksheets("入荷マスター").Range("A1")
'投入表の在庫IDセル位置を基準とする（行見出しのセル位置）
Set rngResult = Worksheets("投入表").Range("A14")
'画面更新を停止
Application.ScreenUpdating = False
'入荷マスターに就いて
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = .Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'在庫ID順の使用期限（年、月、日）順の入荷日順でListを整列
'A列から整列する列の列Offsetを指定,全て昇順で
DataSort .Offset(1).Resize(lngRows, 9), Array(2, 6, 7, 8, 1), _
Array(xlAscending, xlAscending, xlAscending, _
xlAscending, xlAscending)
'全列データを配列に取得
vntData = .Offset(1).Resize(lngRows + 1, 9).Value
End With
'投入表に就いて
With rngResult
'列数の取得
lngColumns = .Offset(, Columns.Count - .Column).End(xlToLeft).Column - .Column
If lngColumns <= 0 Then
strProm = .Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'Set数を取得
vntSets = .Offset(-12, 1).Value
'在庫IDを取得
vntStockID = .Offset(, 1).Resize(, lngColumns).Value
End With
'投入表の在庫IDを横に見て行って
For i = 1 To lngColumns
'出力行位置を初期化
k = 0
'入荷マスタの在庫IDを上から見て行って
For j = 1 To lngRows
'在庫IDが等しいなら
If vntStockID(1, i) = vntData(j, 3) Then
'Forを抜ける
Exit For
End If
Next j
'出力行を更新
k = k + 1
'出力用配列を確保
ReDim vntResult(1 To k * 2)
'在庫IDが等しいなら
If j <= lngRows Then
'必要数を転記
lngCount = vntSets
'入荷日を転記
vntResult(k) = vntData(j, 2)
'使用期限（年&月&日）が日付と認められるなら
If IsDate(vntData(j, 7) & "/" & vntData(j, 8) _
& "/" & vntData(j, 9)) Then
'使用期限を転記
vntResult(k + 1) = DateSerial(vntData(j, 7), _
vntData(j, 8), vntData(j, 9))
Else
'使用期限に*を記入
vntResult(k * 2) = "*"
End If
'必要数から在庫数をマイナス
lngCount = lngCount - vntData(j, 6)
'在庫が必要数を満たす迄繰り返し
Do Until lngCount < 0
'入荷マスタを見る行を更新
j = j + 1
'出力行を更新
k = k + 1
'出力用配列を拡張
ReDim Preserve vntResult(1 To k * 2)
'在庫IDが等しいなら
If vntStockID(1, i) = vntData(j, 3) Then
'入荷日を転記
vntResult(k * 2 - 1) = vntData(j, 2)
'使用期限（年&月&日）が日付と認められるなら
If IsDate(vntData(j, 7) & "/" & vntData(j, 8) _
& "/" & vntData(j, 9)) Then
'使用期限を転記
vntResult(k * 2) = DateSerial(vntData(j, 7), _
vntData(j, 8), vntData(j, 9))
Else
'使用期限に*を記入
vntResult(k * 2) = "*"
End If
'必要数から在庫数を減算
lngCount = lngCount - vntData(j, 6)
Else
vntResult(k * 2 - 1) = "在庫不足"
Exit Do
End If
Loop
Else
vntResult(k * 2 - 1) = "在庫不足"
End If
'結果を出力
rngResult.Offset(1, i).Resize(k * 2).Value _
= WorksheetFunction.Transpose(vntResult)
'出力の最大行数を保存
If lngMax < k Then
lngMax = k
End If
Next i
'入荷日、使用期限を書き込む
ReDim vntResult(1 To 2, 1 To 1)
vntResult(1, 1) = "入荷日"
vntResult(2, 1) = "使用期限"
For i = 0 To lngMax - 1
rngResult.Offset(i * 2 + 1).Resize(2).Value = vntResult
Next i
'入荷マスターに就いてデータを元に戻す
DataSort rngList.Offset(1).Resize(lngRows, 9), Array(0), Array(xlAscending)
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
Private Sub DataSort(rngScope As Range, _
vntKeys As Variant, _
vntOrders As Variant, _
Optional lngOrientation As Long = xlTopToBottom)
' vntKeysで与えられた値をKeyとして整列
Dim i As Long
Dim rngTop As Range
Set rngTop = rngScope.Cells(1, 1)
With rngTop.Parent
.Sort.SortFields.Clear
For i = 0 To UBound(vntKeys, 1)
.Sort.SortFields.Add Key:=rngTop.Offset(, vntKeys(i)) _
, SortOn:=xlSortOnValues, Order:=vntOrders(i) _
, DataOption:=xlSortNormal
Next i
With .Sort
.SetRange rngScope
.Header = xlNo
.MatchCase = False
.Orientation = lngOrientation
.SortMethod = xlStroke
.Apply
End With
End With
Set rngTop = Nothing
End Sub
(Bun)
ごめん、必要数の計算が間違えていました ★印の様に修正して下さい
'在庫が必要数を満たす迄繰り返し
' Do Until lngCount < 0
Do Until lngCount <= 0 '★上記を修正
ありがとうございます！ コメントまで丁寧に入れてくださったのでよくわかりました！
一つだけお聞きしたいのですが、「投入表」がいくつかあって、「投入表ア」「投入表イ」のように 「投入表」が頭についたシートがあります。
この場合、その投入表ごとにマクロを実行するにはどうしたらよいでしょうか？ （“ア”“イ”の部分はその都度変わります）
（雪だるま）
>一つだけお聞きしたいのですが、「投入表」がいくつかあって、「投入表ア」「投入表イ」のように >「投入表」が頭についたシートがあります。 > > >この場合、その投入表ごとにマクロを実行するにはどうしたらよいでしょうか？ >（“ア”“イ”の部分はその都度変わります） >
一番単純な方法の1つは、
'投入表の在庫IDセル位置を基準とする（行見出しのセル位置）
Set rngResult = Worksheets("投入表").Range("A14")
を
'投入表の在庫IDセル位置を基準とする（行見出しのセル位置）
Set rngResult = ActiveSheet.Range("A14")
と変更します そしてマクロを実行する場合、「投入表ア」成り、「投入表イ」成りをActive（このシートが見えている状態） にして、「Sub Sample」を実行します そうすれば、結果Activeにしたシートに反映されます
別案としては
'投入表の在庫IDセル位置を基準とする（行見出しのセル位置）
Set rngResult = Worksheets("投入表").Range("A14")
を「Sub Sample」の引数として外に出します 詰まり、
Public Sub Sample(wksResult As Worksheet)
とします 次に
'投入表の在庫IDセル位置を基準とする（行見出しのセル位置）
Set rngResult = wksResult.Range("A14")
とします、そして此れを呼び出すプロシージャを作ります 例えば「投入表ア」に結果を求めるなら
Public Sub 投入表ア()
Sample Worksheets("投入表ア")
End Sub
と言うプロシージャを投入表分作り、結果を求めたい投入表のプロシージャを実行します
以上
PS：今回仕様として無かったのですが、以下の様にすれば在庫不足が出る場合其の枚数を出す事も出来ます
(Bun)
以下を書き忘れました
'必要数から在庫数を減算
lngCount = lngCount - vntData(j, 6)
Else
' vntResult(k * 2 - 1) = "在庫不足"
vntResult(k * 2 - 1) = lngCount & "枚不足" '★変更
Exit Do
End If
Loop
Else
' vntResult(k * 2 - 1) = "在庫不足"
vntResult(k * 2 - 1) = vntSets & "枚不足" '★変更
End If
'結果を出力
rngResult.Offset(1, i).Resize(k * 2).Value _
= WorksheetFunction.Transpose(vntResult)
'★不足の場合の処理
If Not IsDate(vntResult(k * 2 - 1)) Then
rngResult.Offset(k * 2 - 1, i).Font.Color = vbRed
End If
'出力の最大行数を保存
If lngMax < k Then
lngMax = k
End If
Next i
(Bun)
ありがとうございます！ 追加の処理も助かりました。
すみません、もう一つ条件分岐の方法をお教えください。
商品をセットする際に「"倉庫A東"の"棚B-1"から出す」という指示があります。 マスターの中では
M N O P 倉庫 棟 棚 番号 A 東 B 1
このように4列に分かれているので、右端のAL列に「M列＆N列＆O列＆P列」の結合した作業列を作り、投入表のB7セルに AL列の条件（どこから出すか）を記入しようと思います （手入力ではミスが出ると思うのでリストボックスか何かを置いて…）
一つの投入表ではAL列の条件は全部同じです。
なので IF B7 = "入荷マスター"AL列
というような条件を入れたいのですが、どのような記述をすればよいでしょうか…
後からすみません…上からさきほどこの条件を入れろと言われまして…
よろしくお願いします<(__)>
（雪だるま）
うーん？？？ 言っている意味が今一つ理解出来ないのですが？
こちらの受け取り方は、 1、「投入表」のB7セルに例えば「A東B1」と入れます この意味は、「"倉庫A東"の"棚B-1"から出す」と言う出庫場所指示です 2、この値は、入荷マスターのM列、N列、O列、P列に分割して登録して有ります 3、「投入表」作成時（入荷マスターから在庫IDを探す時）に、 「投入表」B7セルの値と該当「在庫ID」行のM列、N列、O列、P列の値が一致した物だけを 「投入表」の15行目以降に記入する
と言う事でしょうか？
疑問 もし、在庫は有るがB7セルの値と一致しない場合はどうするの？ 本当は入荷マスターの最終列は何処まで在るの？ （コード上で整列するので本当の最終列が解らないと、Listの前半だけ整列されてめちゃくちゃに成る事も 無いとは言えないかも？）
尚、”右端のAL列に「M列＆N列＆O列＆P列」の結合した作業列を作り”と有りますが コード上で文字列の連結は出来ますので、作業列を作る必要は無いと思います 下手に作業列を作りそこへ数式等を入れられると数式が色々と邪魔をする可能性も有ります
(Bun)
説明が下手ですみません…
入荷マスターはAK列まであります。
> 「投入表」作成時（入荷マスターから在庫IDを探す時）に、 > 「投入表」B7セルの値と該当「在庫ID」行のM列、N列、O列、P列の値が一致した物だけを > 「投入表」の15行目以降に記入する
はい、そうです。
> もし、在庫は有るがB7セルの値と一致しない場合はどうするの？
他の倉庫等に在庫があっても、指示した倉庫に在庫がなければ「在庫不足」になります。 顧客から「ここの倉庫のこの棚の分を使ってくれ」という指定がありますので… この4つの組み合わせがいくつもあり、今後も増える予定があるのでIDのようなものが作れなくて…
作業列の件は了解いたしました。
あとすみません、倉庫等の場所「M～P列」と書いてましたが最新のマスターで J列・K列・L列・M列に変わってました。
それと入荷日をAI列にある「入荷受付番号」というところに変更するように言われました。 この「入荷受付番号」は上に書いた「入荷日」を元に作成されている番号で、取り扱いは入荷日と変わらないのですが、 AI列には他の列３つを結合する数式が入っています。
具体的には、
AA AB AC ～ AI 1 入荷日番号 枝番1 枝番2 ～ 入荷受付番号 2 111208 0000 00 ～ 111208000000 3 111208 0001 00 ～ 111208000100 4 111208 0001 01 ～ 111208000101
となるように、AI列に =$AA2&$AB2&$AC2 という数式が入っています (AI列は別のシートで別の帳票を作るのに使用します。)
この数式が邪魔になることはありますか？
何か本当にもうすみません＞＜
（雪だるま）
>この数式が邪魔になることはありますか？
他も含め検討して見ます 少し時間を下さい
(Bun)
>この数式が邪魔になることはありますか？ 一応、問題は出ない様です
今回、出庫場所の件も含め直接「入荷マスター」に整列を掛け其処から投入指示を計算する方法変更します 出庫場所の件、マスタの保護、データのコンパクト化の為 作業用のシートを予め作成し、其処に必要と成るデータをフィルタオプション（AdvancedFilter）を使って 抽出し此れを整列して使用します
先ず、投入表のB7に出庫場所を入れます、この書式は一応、「倉庫」一文字、「棟」一文字、 「棚」一文字、番号幾つでもと考え「A東B1」としてコードを書きます
次に、マクロの有るBookにシートを追加してシート名を「作業用」とします そのシートの1行目に以下の見出しを作ります （AdvancedFilterは見出しに神経質の様なので入荷マスターから必ずコピーして作って下さい）
「作業用」シートの抽出範囲として
Ａ Ｂ Ｃ Ｄ Ｅ Ｆ Ｇ 入荷ID 入荷受付番号 在庫ID 入荷実数 使用期限（年） 使用期限（月） 使用期限（日）
Ｈ Ｉ Ｊ Ｋ 倉庫 棟 棚 番号
「作業用」の条件範囲として
Ｎ Ｏ Ｐ Ｑ Ｒ 在庫ID 倉庫 棟 棚 番号
として下さい、此処に条件を入れて抽出します 「作業用」シートは五月蠅ければ非表示にして下さい（テスト中は表示して置いた方が善いかも）
コードは
Option Explicit
Public Sub Sample_2()
Dim i As Long
Dim j As Long
Dim k As Long
Dim lngRows As Long
Dim lngColumns As Long
Dim rngList As Range
Dim rngResult As Range
Dim rngWork As Range
Dim vntData As Variant
Dim vntSets As Variant
Dim vntPlace As Variant
Dim lngCount As Long
Dim vntStockID As Variant
Dim vntResult As Variant
Dim lngMax As Long
Dim strProm As String
'入荷マスターListの先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngList = Worksheets("入荷マスター").Range("A1")
'投入表の在庫IDセル位置を基準とする（行見出しのセル位置）
Set rngResult = Worksheets("投入表").Range("A14")
'作業用シートの抽出範囲の先頭セル位置(マスタから必要データを抽出)
Set rngWork = Worksheets("作業用").Range("A1")
'画面更新を停止
Application.ScreenUpdating = False
'投入表に就いて
With rngResult
'列数の取得
lngColumns = .Offset(, Columns.Count - .Column).End(xlToLeft).Column - .Column
If lngColumns <= 0 Then
strProm = .Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'Set数を取得
vntSets = .Parent.Range("B2").Value
'出庫場所を取得
vntPlace = .Parent.Range("B7").Value
'在庫IDを取得
vntStockID = .Offset(, 1).Resize(, lngColumns).Value
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows > 0 Then
.Offset(1).Resize(lngRows).EntireRow.Delete
End If
End With
'入荷マスターから必要データを取得
If Not GetData(vntData, rngList, rngWork, vntStockID, vntPlace) Then
strProm = "データの取得が出来ません、在庫ID、出庫場所等を確認して下さい"
GoTo Wayout
End If
'データ行数を取得
lngRows = UBound(vntData, 1)
'投入表の在庫IDを横に見て行って
For i = 1 To lngColumns
'出力行位置を初期化
k = 0
'入荷マスタの在庫IDを上から見て行って
For j = 1 To lngRows
'在庫IDが等しいなら
If vntStockID(1, i) = vntData(j, 2) Then
'Forを抜ける
Exit For
End If
Next j
'出力行を更新
k = k + 1
'出力用配列を確保
ReDim vntResult(1 To k * 2)
'在庫IDが等しいなら
If j <= lngRows Then
'必要数を転記
lngCount = vntSets
'入荷受付番号を転記
vntResult(k) = "'" & vntData(j, 1)
'使用期限を転記
vntResult(k * 2) = GetDate(vntData(j, 4), vntData(j, 5), vntData(j, 6))
'必要数から在庫数をマイナス
lngCount = lngCount - vntData(j, 3)
'在庫が必要数を満たす迄繰り返し
Do Until lngCount <= 0
'入荷マスタを見る行を更新
j = j + 1
'出力行を更新
k = k + 1
'出力用配列を拡張
ReDim Preserve vntResult(1 To k * 2)
'在庫IDが等しいなら
If vntStockID(1, i) = vntData(j, 2) Then
'入荷受付番号を転記
vntResult(k * 2 - 1) = "'" & vntData(j, 1)
'使用期限を転記
vntResult(k * 2) = GetDate(vntData(j, 4), vntData(j, 5), vntData(j, 6))
'必要数から在庫数を減算
lngCount = lngCount - vntData(j, 3)
Else
vntResult(k * 2 - 1) = lngCount & "枚不足"
Exit Do
End If
Loop
Else
vntResult(k * 2 - 1) = vntSets & "枚不足"
End If
'結果を出力
rngResult.Offset(1, i).Resize(k * 2).Value _
= WorksheetFunction.Transpose(vntResult)
'不足の場合の処理
If InStr(1, vntResult(k * 2 - 1), "枚不足") Then
rngResult.Offset(k * 2 - 1, i).Font.Color = vbRed
End If
'出力の最大行数を保存
If lngMax < k Then
lngMax = k
End If
Next i
'入荷日、使用期限を書き込む
ReDim vntResult(1 To 2, 1 To 1)
vntResult(1, 1) = "入荷日"
vntResult(2, 1) = "使用期限"
For i = 0 To lngMax - 1
rngResult.Offset(i * 2 + 1).Resize(2).Value = vntResult
Next i
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
Set rngWork = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function GetData(vntData As Variant, rngList As Range, _
rngWork As Range, vntStockID As Variant, _
vntPlace As Variant) As Boolean
' 入荷マスターからAdvancedFilterを使ってデータを取得
Dim i As Long
Dim j As Long
Dim vntCrit As Variant
Dim rngCrit As Range
Dim lngRows As Long
'作業用シートの条件範囲の先頭セル位置(マスタから必要データを抽出)
Set rngCrit = rngWork.Parent.Range("N1")
'在庫IDを抽出条件に出力
ReDim vntCrit(1 To UBound(vntStockID, 2), 1 To 5)
For i = 1 To UBound(vntStockID, 2)
vntCrit(i, 1) = "=" & """=" & vntStockID(1, i) & """"
vntCrit(i, 2) = "=" & """=" & Left(vntPlace, 1) & """"
vntCrit(i, 3) = "=" & """=" & Mid(vntPlace, 2, 1) & """"
vntCrit(i, 4) = "=" & """=" & Mid(vntPlace, 3, 1) & """"
vntCrit(i, 5) = "=" & """=" & Mid(vntPlace, 4) & """"
Next i
rngCrit.Offset(1).Resize(UBound(vntStockID, 2), 5).Value = vntCrit
'入荷マスターから必要データを抽出
DoFilter rngList.CurrentRegion, _
rngCrit.Resize(UBound(vntStockID, 2) + 1, 5), _
rngWork.Resize(, 11)
'作業用シートに就いて
With rngWork
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
GoTo Wayout
End If
'在庫ID順の使用期限（年、月、日）順の入荷日順でListを整列
'A列から整列する列の列Offsetを指定,全て昇順で
DataSort .Offset(1).Resize(lngRows, 9), Array(2, 4, 5, 6, 1), _
Array(xlAscending, xlAscending, xlAscending, _
xlAscending, xlAscending)
'全列データを配列に取得
vntData = .Offset(1, 1).Resize(lngRows + 1, 6).Value
End With
GetData = True
Wayout:
Set rngCrit = Nothing
End Function
Private Function GetDate(vntYear As Variant, vntMonth As Variant, _
vntDay As Variant) As Variant
'使用期限（年&月&日）が日付と認められるなら
If IsDate(vntYear & "/" & vntMonth & "/" & vntDay) Then
'シリアル値に変換
GetDate = DateSerial(vntYear, vntMonth, vntDay)
Else
'*を返す
GetDate = "*"
End If
End Function
Private Sub DoFilter(rngScope As Range, _
rngCriteria As Range, _
rngCopyTo As Range, _
Optional blnUnique As Boolean)
' AdvancedFilterを実行
rngScope.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=rngCriteria, _
CopyToRange:=rngCopyTo, _
Unique:=blnUnique
End Sub
Private Sub DataSort(rngScope As Range, _
vntKeys As Variant, _
vntOrders As Variant, _
Optional lngOrientation As Long = xlTopToBottom)
Dim i As Long
Dim rngTop As Range
Set rngTop = rngScope.Cells(1, 1)
With rngTop.Parent
.Sort.SortFields.Clear
For i = 0 To UBound(vntKeys, 1)
.Sort.SortFields.Add Key:=rngTop.Offset(, vntKeys(i)) _
, SortOn:=xlSortOnValues, Order:=vntOrders(i) _
, DataOption:=xlSortNormal
Next i
With .Sort
.SetRange rngScope
.Header = xlNo
.MatchCase = False
.Orientation = lngOrientation
.SortMethod = xlStroke
.Apply
End With
End With
Set rngTop = Nothing
End Sub
(Bun)
お手数をおかけします。 ありがとうございます。
サンプルを作って試したところ、入荷受付番号などは投入表に反映されたのですが、入荷受付番号などが入る行以下 （投入表の15行目以下）の書式（罫線、塗りつぶしなど）や印刷範囲の設定などが全てクリアされてしまいます…
あと倉庫などの部分は、実際は「ロジスティック」「お客様窓口用」などの文字列が入りますが、これは別にマスターを作って 倉庫IDのようなものを作成し、そこから引っ張ってきた方がよいでしょうか。 随時新しいものも追加されるのでどこかを参照し、投入表のB7セルに入力した方が入力ミスで在庫が反映されない、 などの現象が回避できるかと思いまして… （ここは私もどうすれば入力ミスなく記入できるか考えているところです。現在のマスターが全て手入力で 全角半角などの微妙な違いが多いので…）
この部分は自分でももう少し方法を考えてみます
とりあえずもう少し投入表のレイアウトなど考えながら試してみます。
（雪だるま）
>サンプルを作って試したところ、入荷受付番号などは投入表に反映されたのですが、入荷受付番号などが入る行以下 >（投入表の15行目以下）の書式（罫線、塗りつぶしなど）や印刷範囲の設定などが全てクリアされてしまいます…
ゴメン此れはコードの中で不足の場合Font赤に設定する時が有るので投入表の15行目以下を行削除している為です 此れをやめるのは以下を削除すれば止まります
'投入表に就いて
With rngResult
・
・
・
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row '★削除
If lngRows > 0 Then '★削除
.Offset(1).Resize(lngRows).EntireRow.Delete '★削除
End If '★削除
End With
>あと倉庫などの部分は、実際は「ロジスティック」「お客様窓口用」などの文字列が入りますが、これは別にマスターを作って >倉庫IDのようなものを作成し、そこから引っ張ってきた方がよいでしょうか。
入荷マスターにですか、出来ればその方が善いでしょうが？ 「A東B1」としたのは、実際に如何するかが決まって無かったの取り合えずこの様にした迄ですが？ 此れは、例えばカンマやセミコロンやダブルコロン等で区切って此れを区切り文字とすれば 倉庫、棟、棚、番号を分割出来ますので雪だるまさんの方で決めていただければその様に直せます 其の場合、一文字づつ出なくても善いです 例えば、「ロジスティック;東;B;1」や「ロジスティック,東,B,1」等
>（ここは私もどうすれば入力ミスなく記入できるか考えているところです。現在のマスターが全て手入力で 全角半角などの微妙な違いが多いので…）
Upしたマクロでは倉庫、棟、棚、番号をフィルタオプションで絞り込んで居るのですが？ 上記の様に全半角混在の様な状態では絞り込めませんね 一行づつStrCompで確認する様にしますか？
(Bun)
後、書き忘れましたが 倉庫、棟、棚、番号は一つのセルに連結する必要は必ずしも有りませんので 此れが、別々にセルに入っている状態でも構いません、其れなりに取得しますので ただ、マクロを作る上でどのような形で提供されるかが問題ですので、 これをマクロに渡す方式を早く確立して下さい 其れにより、倉庫等の文字列に全半角が混在する程度なら「する」と言えば 其れ成りの対処も出来ると思います
(Bun)
一応、倉庫、棟、棚、番号はフィルタオプションでの絞り込みを諦め 全半角の吸収を行う為に、行を上から見て行く時点でStrComp関数で比較を行う様に変更しました ただ、不要データの排除、マスタの保護の為にフィルタオプション自体は使用します 因って「作業用」シートは全く同じ物を使用しますので其のままにして下さい
また、「投入表」のB7の書式は一旦、例えば「ロジスティック:東:B:1」の様に 区切り文字に「:」ダブルコロンを挟んだ連結にして置きます 此れは、「投入表」の仕様が決まった時点で変更すれば宜しいかと思います これで、運用テスト程度は出来るのでは思いますので、テストして不都合を纏めて下さい
尚、「投入表」の15行目以下の削除はコメントアウトで止めて有ります
Option Explicit
Public Sub Sample_3()
Dim i As Long
Dim j As Long
Dim k As Long
Dim lngRows As Long
Dim lngColumns As Long
Dim rngList As Range
Dim rngResult As Range
Dim rngWork As Range
Dim vntData As Variant
Dim vntSets As Variant
Dim vntPlace As Variant
Dim lngCount As Long
Dim vntStockID As Variant
Dim vntResult As Variant
Dim lngMax As Long
Dim strProm As String
'入荷マスターListの先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngList = Worksheets("入荷マスター").Range("A1")
'投入表の在庫IDセル位置を基準とする（行見出しのセル位置）
Set rngResult = Worksheets("投入表").Range("A14")
'作業用シートの抽出範囲の先頭セル位置(マスタから必要データを抽出)
Set rngWork = Worksheets("作業用").Range("A1")
'画面更新を停止
Application.ScreenUpdating = False
'投入表に就いて
With rngResult
'列数の取得
lngColumns = .Offset(, Columns.Count - .Column).End(xlToLeft).Column - .Column
If lngColumns <= 0 Then
strProm = .Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'Set数を取得
vntSets = .Parent.Range("B2").Value
If Val(vntSets) < 1 Then
strProm = "セット数が設定されていません"
GoTo Wayout
End If
'出庫場所を取得
vntData = .Parent.Range("B7").Value
vntPlace = Split(vntData, ":", , vbTextCompare)
If UBound(vntPlace, 1) < 3 Then
strProm = "出庫場所の入力が正しく有りません"
GoTo Wayout
End If
'在庫IDを取得
vntStockID = .Offset(, 1).Resize(, lngColumns).Value
'行数の取得
' lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row '★削除
' If lngRows > 0 Then '★削除
' .Offset(1).Resize(lngRows).EntireRow.Delete '★削除
' End If '★削除
End With
'入荷マスターから必要データを取得
If Not GetData(vntData, rngList, rngWork, vntStockID) Then
strProm = "データの取得が出来ません、在庫ID、出庫場所等を確認して下さい"
GoTo Wayout
End If
'データ行数を取得
lngRows = UBound(vntData, 1)
'投入表の在庫IDを横に見て行って
For i = 1 To lngColumns
'出力行位置を初期化
k = 0
'入荷マスタの在庫IDを上から見て行って
For j = 1 To lngRows
'在庫IDが等しいなら
If vntStockID(1, i) = vntData(j, 2) Then
'出庫場所のチェックがTrueなら
If PlaceCheck(vntPlace, j, vntData) Then
'Forを抜ける
Exit For
End If
End If
Next j
'出力行を更新
k = k + 1
'出力用配列を確保
ReDim vntResult(1 To k * 2)
'在庫IDが等しいなら
If j <= lngRows Then
'必要数を転記
lngCount = vntSets
'入荷受付番号を転記
vntResult(k) = "'" & vntData(j, 1)
'使用期限を転記
vntResult(k * 2) = GetDate(vntData(j, 4), vntData(j, 5), vntData(j, 6))
'必要数から在庫数をマイナス
lngCount = lngCount - vntData(j, 3)
'在庫が必要数を満たす迄繰り返し
Do Until lngCount <= 0
'入荷マスタを見る行を更新
j = j + 1
'在庫IDが等しいなら
If vntStockID(1, i) = vntData(j, 2) Then
'出庫場所のチェックがTrueなら
If PlaceCheck(vntPlace, j, vntData) Then
'出力行を更新
k = k + 1
'出力用配列を拡張
ReDim Preserve vntResult(1 To k * 2)
'入荷受付番号を転記
vntResult(k * 2 - 1) = "'" & vntData(j, 1)
'使用期限を転記
vntResult(k * 2) = GetDate(vntData(j, 4), vntData(j, 5), vntData(j, 6))
'必要数から在庫数を減算
lngCount = lngCount - vntData(j, 3)
End If
Else
'出力行を更新
k = k + 1
'出力用配列を拡張
ReDim Preserve vntResult(1 To k * 2)
vntResult(k * 2 - 1) = lngCount & "枚不足"
Exit Do
End If
Loop
Else
vntResult(k * 2 - 1) = vntSets & "枚不足"
End If
'結果を出力
rngResult.Offset(1, i).Resize(k * 2).Value _
= WorksheetFunction.Transpose(vntResult)
'不足の場合の処理
If InStr(1, vntResult(k * 2 - 1), "枚不足") Then
rngResult.Offset(k * 2 - 1, i).Font.Color = vbRed
End If
'出力の最大行数を保存
If lngMax < k Then
lngMax = k
End If
Next i
'入荷日、使用期限を書き込む
ReDim vntResult(1 To 2, 1 To 1)
vntResult(1, 1) = "入荷日"
vntResult(2, 1) = "使用期限"
For i = 0 To lngMax - 1
rngResult.Offset(i * 2 + 1).Resize(2).Value = vntResult
Next i
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
Set rngWork = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function PlaceCheck(vntCheck As Variant, _
lngPos As Long, vntData As Variant) As Boolean
Dim i As Long
'倉庫、棟、棚、番号をチェック
For i = 0 To UBound(vntCheck, 1)
If StrComp(vntCheck(i), vntData(lngPos, i + 7), vbTextCompare) <> 0 Then
Exit For
End If
Next i
'全て一致の場合
If i > UBound(vntCheck, 1) Then
'戻り値としてTrueを返す
PlaceCheck = True
End If
End Function
Private Function GetData(vntData As Variant, rngList As Range, _
rngWork As Range, vntStockID As Variant) As Boolean
' 入荷マスターからAdvancedFilterを使ってデータを取得
Dim i As Long
Dim j As Long
Dim vntCrit As Variant
Dim rngCrit As Range
Dim lngRows As Long
'作業用シートの条件範囲の先頭セル位置(マスタから必要データを抽出)
Set rngCrit = rngWork.Parent.Range("N1")
'在庫IDを抽出条件に出力
ReDim vntCrit(1 To UBound(vntStockID, 2), 1 To 1)
For i = 1 To UBound(vntStockID, 2)
vntCrit(i, 1) = "=" & """=" & vntStockID(1, i) & """"
Next i
rngCrit.Offset(1).Resize(UBound(vntStockID, 2)).Value = vntCrit
'入荷マスターから必要データを抽出
DoFilter rngList.CurrentRegion, _
rngCrit.Resize(UBound(vntStockID, 2) + 1), _
rngWork.Resize(, 11)
'作業用シートに就いて
With rngWork
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
GoTo Wayout
End If
'在庫ID順の使用期限（年、月、日）順の入荷日順でListを整列
'A列から整列する列の列Offsetを指定,全て昇順で
DataSort .Offset(1).Resize(lngRows, 11), Array(2, 4, 5, 6, 1), _
Array(xlAscending, xlAscending, xlAscending, _
xlAscending, xlAscending)
'全列データを配列に取得
vntData = .Offset(1, 1).Resize(lngRows + 1, 10).Value
End With
GetData = True
Wayout:
Set rngCrit = Nothing
End Function
Private Function GetDate(vntYear As Variant, vntMonth As Variant, _
vntDay As Variant) As Variant
'使用期限（年&月&日）が日付と認められるなら
If IsDate(vntYear & "/" & vntMonth & "/" & vntDay) Then
'シリアル値に変換
GetDate = DateSerial(vntYear, vntMonth, vntDay)
Else
'*を返す
GetDate = "*"
End If
End Function
Private Sub DoFilter(rngScope As Range, _
rngCriteria As Range, _
rngCopyTo As Range, _
Optional blnUnique As Boolean)
' AdvancedFilterを実行
rngScope.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=rngCriteria, _
CopyToRange:=rngCopyTo, _
Unique:=blnUnique
End Sub
Private Sub DataSort(rngScope As Range, _
vntKeys As Variant, _
vntOrders As Variant, _
Optional lngOrientation As Long = xlTopToBottom)
Dim i As Long
Dim rngTop As Range
Set rngTop = rngScope.Cells(1, 1)
With rngTop.Parent
.Sort.SortFields.Clear
For i = 0 To UBound(vntKeys, 1)
.Sort.SortFields.Add Key:=rngTop.Offset(, vntKeys(i)) _
, SortOn:=xlSortOnValues, Order:=vntOrders(i) _
, DataOption:=xlSortNormal
Next i
With .Sort
.SetRange rngScope
.Header = xlNo
.MatchCase = False
.Orientation = lngOrientation
.SortMethod = xlStroke
.Apply
End With
End With
Set rngTop = Nothing
End Sub
(Bun)
本当にお手数をおかけします。
>倉庫、棟、棚、番号は一つのセルに連結する必要は必ずしも有りませんので 例えば「投入表」のB7、C7と複数セルに入力しても大丈夫ということでしょうか？
倉庫～の件でいくつか変更とこちらで考えたことがありますのでとりあえずまとめます。
・参照するのは「倉庫」「棟」の2列だけでOK（棚と番号は不要） ・マスターが全角半角のほかに「お客様対応用」「お客さま対応」など同じ内容でまったく違う書き方をしているものがあるので、 別シートに「倉庫・棚マスター」を作り、入力規則と名前の定義を利用してマスター・投入表ともプルダウンリストから選択するようにしようと思います。 それで、できれば投入表のB7に「倉庫」C7に「棟」の項目を、それぞれ入力規則で入れようと思います。
これで一度マスターをメンテしてから教えていただいたコードでテストしてみます。 ありがとうございます。
（雪だるま）
>>倉庫、棟、棚、番号は一つのセルに連結する必要は必ずしも有りませんので >例えば「投入表」のB7、C7と複数セルに入力しても大丈夫ということでしょうか？
大丈夫です、但しUpしたマクロではその様な入力に対してのコードに成っているので 一部コードの変更が必要に成ります
>倉庫～の件でいくつか変更とこちらで考えたことがありますのでとりあえずまとめます。 > > >・参照するのは「倉庫」「棟」の2列だけでOK（棚と番号は不要） >・マスターが全角半角のほかに「お客様対応用」「お客さま対応」など同じ内容でまったく違う書き方をしているものがあるので、 >別シートに「倉庫・棚マスター」を作り、入力規則と名前の定義を利用してマスター・投入表ともプルダウンリストから選択するようにしようと思います。 >それで、できれば投入表のB7に「倉庫」C7に「棟」の項目を、それぞれ入力規則で入れようと思います。
>これで一度マスターをメンテしてから教えていただいたコードでテストしてみます。
では、その様な仕様でコードの変更をしますか？
(Bun)
BUN様
>その様な仕様でコードの変更をしますか？
はい、お願いします<(__)>
（雪だるま）
マクロの仕様変更をしました 「投入表」のB7に「倉庫」、C7に「棟」が入ります
以下の★印を変更、追加して下さい（前のコードはコメントアウトして残して有ります）
「Sub Sample_3」のプロシージャの中の
'投入表に就いて
With rngResult
'列数の取得
lngColumns = .Offset(, Columns.Count - .Column).End(xlToLeft).Column - .Column
If lngColumns <= 0 Then
strProm = .Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'Set数を取得
vntSets = .Parent.Range("B2").Value
If Val(vntSets) < 1 Then
strProm = "セット数が設定されていません"
GoTo Wayout
End If
'出庫場所を取得
' vntData = .Parent.Range("B7").Value
' vntPlace = Split(vntData, ":", , vbTextCompare)
' If UBound(vntPlace, 1) < 3 Then
' strProm = "出庫場所の入力が正しく有りません"
' GoTo Wayout
' End If
vntPlace = .Parent.Range("B7:C7").Value '★変更
'在庫IDを取得
' vntStockID = .Offset(, 1).Resize(, lngColumns).Value
'★「投入表」の在庫IDが1列の場合に対処
vntStockID = .Offset(, 1).Resize(, lngColumns + 1).Value '★変更
ReDim Preserve vntStockID(1 To 1, 1 To lngColumns) '★追加
'行数の取得
' lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row '★削除
' If lngRows > 0 Then '★削除
' .Offset(1).Resize(lngRows).EntireRow.Delete '★削除
' End If '★削除
End With
「Function PlaceCheck」に就いては
Private Function PlaceCheck(vntCheck As Variant, _
lngPos As Long, vntData As Variant) As Boolean
Dim i As Long
'倉庫、棟、棚、番号をチェック
' For i = 0 To UBound(vntCheck, 1)
For i = 1 To UBound(vntCheck, 2) '★変更
' If StrComp(vntCheck(i), vntData(lngPos, i + 7), vbTextCompare) <> 0 Then
If StrComp(vntCheck(1, i), vntData(lngPos, i - 1 + 7), vbTextCompare) <> 0 Then '★変更
Exit For
End If
Next i
'全て一致の場合
' If i > UBound(vntCheck, 1) Then
If i > UBound(vntCheck, 2) Then '★変更
'戻り値としてTrueを返す
PlaceCheck = True
End If
End Function
以上です
(Bun)
ありがとうございます。 テストデータで試したところ思い通りの結果が出ました。
すみません、もう一つだけお聞きしたいのですが（本当にすみません）
質問の最初に書いた入荷マスターのレイアウト
A B C D E F G H I 1 入荷ID 入荷日 在庫ID 品名 入荷予定数 入荷実数 使用期限（年） 使用期限（月） 使用期限（日）
この並びが変わったり間に別のデータの列が挿入された場合、どの部分を変更すればよいでしょうか。
最初にアップしていただいたコードでは offsetプロパティの引数をいじったりしてできたのですが、今回の マスターから作業用シートにデータを渡す際にどの部分でマスターの列を指定しているのかがよく分かりません…
すみません、最初に質問した時に、必要なデータの列がA～AD列（+AI列）までバラバラに散らばっていたので、 必要な列だけをまとめた内容を記載したんです…
実際は
上の例 → 実際の列 入荷ID： A A 入荷日： B I 在庫ID： C N 品名： D O 入荷予定数：E P 入荷実数： F Q 使用期限年：G AB 使用期限月：H AC 使用期限日：I AD
となっています。 変更部分だけ教えていただけましたらこちらで作業しますので、どの部分かだけお教えいただけますでしょうか。 倉庫・棟・入荷受付番号の列は変わりません。
結果的に余計な手間をおかけすることになってしまい、申し訳ございません。
よろしくお願いいたします。
（雪だるま）
>この並びが変わったり間に別のデータの列が挿入された場合、どの部分を変更すればよいでしょうか。
>最初にアップしていただいたコードでは offsetプロパティの引数をいじったりしてできたのですが、今回の >マスターから作業用シートにデータを渡す際にどの部分でマスターの列を指定しているのかがよく分かりません…
>すみません、最初に質問した時に、必要なデータの列がA～AD列（+AI列）までバラバラに散らばっていたので、 >必要な列だけをまとめた内容を記載したんです…
今回の場合、原則的にマクロの変更は必要有りません その様な事も含め、「作業用」シートにフィルタオプション（AdvancedFilter）でデータを抽出しています この場合、抽出元の「入荷マスタ」の列見出しと抽出先の「作業用」の列見出しが同じ物が抽出されます 因って、「作業用」の抽出範囲と条件範囲の列見出しが「入荷マスタ」に無ければエラーを起こしますが 有れば、其処の列見出しの列に抽出されます 「入荷マスタ」の列が挿入削除で列位置が変わっても、列見出しさえ変更が無ければ其のまま使えます 此処で、 一番大事な事は「作業用」の列見出しの順番と列位置を変更しない事です また、私の方で指示した「作業用」の列見出しが「入荷マスタ」と違っていた場合、「作業用」の列見出しを「入荷マスタ」に合わせて下さい この場合、手入力で「作業用」の列見出しを変更するのでは無く、必ず「入荷マスタ」の列見出しをCopyして下さい （フィルタオプションは神経質なので、人間が見て一見同じに見えても Spaceが入っていたりで気が付かない事が有り結果的に抽出出来ないトラブルが結構有ります）
上記が守られ「作業用」に抽出が出来ていれば大丈夫だと思います
(Bun)
ありがとうございます。 できました！ 本当に助かりました！
（雪だるま）
1つ聞きたいのですが？ このマクロが行っている処理の概要が解っているのかが聞きたいのですが？ コーディング技術と言う意味では無く、手順に就いてです 此れが解ってないと、この後メンテナンスでも、運用で説明するにしても困るのでは？
(Bun)
もう見ていないかな？ ごめん、思い込みが激しい様でコードはもっと簡単で済みました 以下の様に、「 Sub Sample_3」の「'投入表の在庫IDを横に見て行って」～「Next i」迄を差し替えて下さい
'投入表の在庫IDを横に見て行って
For i = 1 To lngColumns
'必要数を転記
lngCount = vntSets
'出力用配列を初期化
ReDim vntResult(1 To 1)
'入荷マスタの在庫IDを上から見て行って
j = 1
'出力行数を初期化
k = 0
Do Until lngCount <= 0
'在庫IDが等しいなら
If vntStockID(1, i) = vntData(j, 2) Then
'出庫場所のチェックがTrueなら
If PlaceCheck(vntPlace, j, vntData) Then
'出力行を更新
k = k + 1
'出力用配列を拡張
ReDim Preserve vntResult(1 To k * 2)
'入荷受付番号を転記
vntResult(k * 2 - 1) = "'" & vntData(j, 1)
'使用期限を転記
vntResult(k * 2) = GetDate(vntData(j, 4), vntData(j, 5), vntData(j, 6))
'必要数から在庫数を減算
lngCount = lngCount - vntData(j, 3)
End If
End If
'入荷マスタを見る行を更新
j = j + 1
If j > lngRows Then
'出力行を更新
k = k + 1
'出力用配列を拡張
ReDim Preserve vntResult(1 To k * 2)
vntResult(k * 2 - 1) = lngCount & "枚不足"
Exit Do
End If
Loop
'結果を出力
rngResult.Offset(1, i).Resize(UBound(vntResult)).Value _
= WorksheetFunction.Transpose(vntResult)
'不足の場合の処理
If InStr(1, vntResult(k * 2 - 1), "枚不足") Then
rngResult.Offset(k * 2 - 1, i).Font.Color = vbRed
End If
'出力の最大行数を保存
If lngMax < k Then
lngMax = k
End If
Next i
(Bun)
BUN様
すみません、土日休みのため今見ました…
手順はコメントを細かく書いていただいているので何をしているかは大体分かります。 「画面更新の停止」「再開」というのが最初は分からなかったのですがGoogleで検索して多分理解できたと思います。
ところで、前に書きました「投入表が複数存在する場合」の対処は
> '投入表の在庫IDセル位置を基準とする（行見出しのセル位置）
> Set rngResult = Worksheets("投入表").Range("A14")
>を
> '投入表の在庫IDセル位置を基準とする（行見出しのセル位置）
> Set rngResult = ActiveSheet.Range("A14")
この方法で問題ないでしょうか。
あともう１点、上から「１行目にタイトル行（2011年12月入荷マスターというような）を入れたい」と言われたので
'入荷マスターListの先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngList = Worksheets("マスター").Range("A2")
と列見出しのセル位置をA1→A2にしてみましたが「フィールド名が無いか無効なフィールドです」のエラーになります。
大幅な変更が必要であればこれは断りますが、どこか他に変更すべきところがあるのでしょうか？
それと、この後多分マスターから使用した分を差し引く処理をするように要求されると思うのですが、 その際、lngCount の値を参照するような形で大丈夫でしょうか。 （これ以上のお願いはできないと思うので在庫更新処理は何とか自力で考えようと思っています）
何度も申し訳ございません＞＜
（雪だるま）
>手順はコメントを細かく書いていただいているので何をしているかは大体分かります。
其れなら宜しいのですが このマクロは人間が紙と鉛筆（マスタシートと投入表）で手で行う方法を其のままExcel上で行って いる物なので、イメージしやすいかと思います
>ところで、前に書きました「投入表が複数存在する場合」の対処は >この方法で問題ないでしょうか。
問題無いと思います
>あともう１点、上から「１行目にタイトル行（2011年12月入荷マスターというような）を入れたい」と言われたので
> '入荷マスターListの先頭セル位置を基準とする（先頭列の列見出しのセル位置）
> Set rngList = Worksheets("マスター").Range("A2")
>と列見出しのセル位置をA1→A2にしてみましたが「フィールド名が無いか無効なフィールドです」のエラーになります。
>大幅な変更が必要であればこれは断りますが、どこか他に変更すべきところがあるのでしょうか？
此れは、「作業用」に抽出する時、フィルタオプション（AdvancedFilter）のリスト範囲を入荷マスタのA1の
CurrentRegionで取っているので、CurrentRegionの場合セル範囲が連続していると其処までListとして受け取ります
因って、タイトルを入れた1行目に列見出しが有る物しますのでrngListをRange("A2")にしても
Excel側はRange("A1")に設定しているのと同じと捉えている為、「フィールド名が無いか無効なフィールドです」のエラーが出ます
此れを回避するには、1行目にタイトルを入れ、1行開けて（2行目は全て空白のセル範囲）Listが3行目と成る様にし
'入荷マスターListの先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngList = Worksheets("マスター").Range("A3")
をA3に指定すれば大丈夫だと思います
>それと、この後多分マスターから使用した分を差し引く処理をするように要求されると思うのですが、 >その際、lngCount の値を参照するような形で大丈夫でしょうか。 >（これ以上のお願いはできないと思うので在庫更新処理は何とか自力で考えようと思っています）
其の場合、現在のマクロでは配列に組み入れてはいませんが（「作業用」では抽出しています） 使用したレコードの「入荷ID」を頼りに減残を行う様です 現在マクロで行うのが一番間違いが無いのですが、結構メンドクサイかも？ 因って、別のマクロ作った方が楽かな？ （其の時使った「作業用」の抽出行を別なシートに保存しておけば楽だと思います）
(Bun)
>それと、この後多分マスターから使用した分を差し引く処理をするように要求されると思うのですが、
此れの件で、Upした後思いついたのですが？
「投入表」の記述の在る範囲の右側は空いて居るのでしょうか？ もし空いているなら、どの列以降か知りたいのですが？ 其処へ、使ったレコードを「入荷ID」を含め出力してしまえば善いのでは？ 「入荷ID」がマスタにおいてユニークでListは、この項目をKeyとして昇順整列されているなら 後から、マスタの減残が出来ると思いますよ
(Bun)
ありがとうございます。 見出しの件、了解いたしました。
在庫処理はマクロを別に作った方がよいのですね。
>「投入表」の記述の在る範囲の右側は空いて居るのでしょうか？ はい、O列以降が印刷範囲外で空いています。 使ったレコードとは「作業用」に抽出された内容のようなものでしょうか。
上の追加レスをいただく前に考えていたコード↓
If 「投入表の入荷受付番号」 = 「作業用の入荷受付番号」 Then
If 「1行目の在庫数」- 「セット数」 >= 0 Then 在庫数 = 「1行目の在庫数」- 「セット数」 Else 「投入表の次の行の入荷受付番号」 = 「作業用の次の行の入荷受付番号」 Then 在庫数 = 「2行目の在庫数」- （「1行目の在庫数」- 「セット数」）
： ： ：
こんな感じでしょうか。 頭では何となく計算方法は分かっているのですがまだうまくコードに表せなくて… ちょっと整理しながら考えてみます。 ありがとうございます。
（雪だるま）
1つ聞きたい事が有ります、元の「入荷マスタ」のレコードを特定する為のKeyとして 元の「入荷マスタ」が昇順整列されている一意（ユニーク）の項目が知りたいのですが？ 「入荷ID」の項目ですか「入荷受付番号」ですか？ 此れによりマクロが変わってきます（一意で昇順整列されているKeyなら、Keyの探索を速くする事が出来ます）
私が思い就いた、今回の手順は以下の様かと思います？
1、「投入表」を作成するマクロの中で、「投入表」のO1を基準とし （列見出しをO1:P1とし、データをO2以下とします） O列に「入荷ID」若しくは「入荷受付番号」を記載し、P列に使用数量を記載します 此れは、「投入表」その物がマスタの一意で昇順整列されているKeyと明確な使用数量を持っていない為に 「投入表」作成時に此れを記録して置こうと言う事です 2、「投入表」で使用された数量を「入荷マスタ」から減算させるマクロを作成します 此れの意味は、「投入表」計算時に在庫不足等でセット数等を変更して再計算する場合を考慮して （作成時に在庫引当でマスタから減算を行うと在庫がめちゃくちゃに成る） 別マクロにすれば、「投入表」が確定した後に明示的に在庫引当（在庫の減算）が行えます 3、このマクロを実行すると、「投入表」O～P列を上から見て行ってO列の「入荷ID」若しくは「入荷受付番号」を 「入荷マスタ」の「入荷ID」若しくは「入荷受付番号」から探索します、 探索方法はワークシート関数のMatch関数の二分探索か自前の二分探索を使います （この時、探索される側のKeyが昇順整列されている必要がある） 見つかれば、そのレコードの「入荷実数」からP列の使用数を減算します 此れを、「投入表」のO～P列の最後迄繰り返します 以上
>上の追加レスをいただく前に考えていたコード↓ > > >If 「投入表の入荷受付番号」 = 「作業用の入荷受付番号」 Then > > > If 「1行目の在庫数」- 「セット数」 >= 0 Then > 在庫数 = 「1行目の在庫数」- 「セット数」 > Else > 「投入表の次の行の入荷受付番号」 = 「作業用の次の行の入荷受付番号」 Then > 在庫数 = 「2行目の在庫数」- （「1行目の在庫数」- 「セット数」） > > >： ： ： > > >こんな感じでしょうか。
に就いては、何処に書くコードか解りませんが？ 先ず、「投入表の入荷受付番号」と在りますが、現状の「投入表」では何処にも「入荷受付番号」番号の記載が有りません また、「在庫数 = 「1行目の在庫数」- 「セット数」」と在りますが、「作業用」のListは「入荷マスタ」に 直接リンクしていないので、「作業用」のListを書き換えても「入荷マスタ」に反映しません 因って、「入荷マスタ」から直接探索しなければ成りません、 「入荷受付番号」が「入荷マスタ」の一意で昇順整列されているKeyで無ければ、「入荷マスタ」の「入荷受付番号」を上から順番に見て行く逐次探索と成り、非常に時間が掛かります もし、別マクロとして上記のコードを作るとした場合のコードもどきを書くと以下の様に成ります
For i=2 to 「投入表O～P列の最終行」
For j = 3 to 「入荷マスタの最終行」
If 「入荷マスタの入荷受付番号」 = 「投入表O列の入荷受付番号」 Then
「入荷マスタの入荷実数」 = 「入荷マスタの入荷実数」 - 「投入表P列の使用数」
Exit For
End If
Next j
Next i
と成ります
(Bun)
> 元の「入荷マスタ」が昇順整列されている一意（ユニーク）の項目が知りたいのですが？ >「入荷ID」の項目ですか「入荷受付番号」ですか？
「入荷ID」がユニークかつ昇順で整列されています。 入荷受付番号もユニークですが一番の元になっているのは入荷IDの方です。
>何処に書くコードか解りませんが？ すみません、別のモジュールに書いてコマンドボタンで実行という感覚でした。 投入表の入荷受付番号はマクロ実行後に15行目・17行目～に出てくるのでそれを参照しようかと思っていました。
随分勘違いしてたんですね、私…
投入表のO・P列にデータを書きだしていく方でやりたいと思います。
（雪だるま）
私の方は、更新マクロの作成と「投入表」作成マクロの変更は出来ました しかし、Upする事は簡単ですが？ 雪だるまさんの方も、今回の更新マクロの作成と「投入表」作成マクロの変更に就いて考え見て下さい 完全なコードで無くても結構ですので、考え方ぐらいは書けるでしょうから（コード無くても結構です） 其れが出て来たら、私の方もUpします 其の方がマクロを理解出来ると思いますので
(Bun)
Bun様 了解いたしました。 頑張ってコード書いてみます。
すみません、今テストしていて気がついたのですが、例えば「パンフA」という商品で使用期限が入っているものと 入っていないものが混在する場合、優先的に使用期限が入っているものが投入表に使われます。
入荷日 使用期限 11/1 ** 11/2 ** 11/15 12/2/20 ←これが優先的に使われる 11/20 12/3/15
入荷日と使用期限と両方を見るのは難しいでしょうか…
（雪だるま）
変ですね？ コード的には、在庫ID昇順の使用期限（年、月、日）昇順の入荷日昇順でListを整列していますので 使用期限の年、月、日が数値として入っていれば
入荷日 使用期限 11/15 12/2/20 ←これが優先的に使われる 11/20 12/3/15 11/1 ** 11/2 **
こう言う整列状態と成りますので使用期限の在るもが使われる筈ですか？ 私の方のテストデータでも上記の状態に成ります
しかし、使用期限の年、月、日が文字列として入っている場合は
入荷日 使用期限 11/1 ** ←これが優先的に使われる 11/2 ** 11/15 12/2/20 11/20 12/3/15
雪だるまさんの言われる整列状態と成る為、使用期限の無い物が先に使われる事と成ります 使用期限の年、月、日が文字列かを確認して見て下さい
もし、として入っているのなら以下を変更して見て下さい 此れにすると、「整列時に数値と見なせる物は全て数値として整列すると成ります」ので 私の言う昇順に成ると思います
変更箇所は、「Private Sub DataSort」中の
With rngTop.Parent
.Sort.SortFields.Clear
For i = 0 To UBound(vntKeys, 1)
' .Sort.SortFields.Add Key:=rngTop.Offset(, vntKeys(i)) _
' , SortOn:=xlSortOnValues, Order:=vntOrders(i) _
' , DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=rngTop.Offset(, vntKeys(i)) _
, SortOn:=xlSortOnValues, Order:=vntOrders(i) _
, DataOption:=xlSortTextAsNumbers '★変更
Next i
と成り、DataOptionプロパティをxlSortNormalからxlSortTextAsNumbersに変更します
(Bun)
ん！、雪だるまさんの言っている意味を取り違えているのかな？
私としては、使用期限の有る物の方が使用期限の無い物より先に消費するのが順当と考えますが？ 反対なのですか？
(Bun)
すみません、使用期限の説明が不足していました。 現在使用期限は3列にわたっていますが全て数値で入力されています。 （入荷受付番号は文字列）
このマスターは多数の人が入力しているため、同じ商品でも使用期限が複数あるものが同時に入ってきた場合、今まで
・使用期限をこまめに分けて（同じ商品を複数行にわたって）入力する人 ・使用期限をまとめて（商品を1行にまとめて）「**/**/**」のように入力する人
というように、入力規則が統一されていなかったんです。 今後は使用期限をこまめに入れる方向で統一しようとなっているのですが、これまでのマスターが上記のようになっていますので、出荷の条件では
「入荷日もしくは使用期限のどちらかが早い方から順に」
という感じになります。
なので
入荷日 使用期限 使われる順番 11/1 ** ①←これが優先的に使われる 11/2 ** ② 11/15 12/2/20 ④ 11/20 12/3/15 ⑤ 11/21 12/1/31 ③
このようにしたいのです。
言葉が足りずに誤解を招きまして申し訳ございません…
（雪だるま）
朝からずっと考えてまずは投入表のO・P列に作業列を書きだす仕組みを考えていたのですが、
Sub Sample_3 に下記を追加
Dim cnt As Long ←追加
Dim sagyoGrp As Variant ←追加
投入表に作業列（O・P列）を作成（行見出しのセル位置） ←追加
Set sagyoGrp = ActiveSheet.Range("O1") ←追加
'在庫IDが等しいなら
If vntStockID(1, i) = vntData(j, 2) Then
'出庫場所のチェックがTrueなら
If PlaceCheck(vntPlace, j, vntData) Then
'出力行を更新
k = k + 1
'出力用配列を拡張
ReDim Preserve vntResult(1 To k * 2)
入荷IDを転記 ←追加
sagyoGrp(cnt,1) = vntData(j, 0) ←追加
使用数量を転記 ←追加
sagyoGrp(cnt,2) = vntData(j, 3) ←追加
'入荷受付番号を転記
vntResult(k * 2 - 1) = "'" & vntData(j, 1)
'使用期限を転記
vntResult(k * 2) = GetDate(vntData(j, 4), vntData(j, 5), vntData(j, 6))
'必要数から在庫数を減算
lngCount = lngCount - vntData(j, 3)
End If
End If
とりあえずこのような感じかと思いましたが当然の如くエラー（インデックスが有効範囲にありません）が出ます。
変数cntの使い方がおかしいような気がするのですが変数をどのようにカウントすればよいのかが分からず…
O列=vntData(j, 0) （入荷ID） P列=vntData(j, 3) （使用数量）
という考え方もおかしいでしょうか…
（雪だるま）
1、転記するコード書く位置は概ね善いと思います 一応、何処で何を行っているか理解している様で頑張ってますね 2、変数cntの使い方に就いて、配列内の行位置を表していると思いますが 変数sagyoGrpが配列として確保されていないのでエラーに成ると思います 適当な位置で「ReDim Preserve sagyoGrp(1 To 2, 1 To cnt)」等と配列の確保を行います 尚上記の「Preserve」は配列の中身を残して配列の要素を拡張する事を表しています また、拡張は最後の次元(cnt)の位置しか代えられません ですから、今回の場合、出力する「入荷ID」の数が決定されていませんので、配列を拡張しながら 配列の1行目に「入荷ID」を転記、2行目に「使用数」を転記し最後出力する時に行列を入れ替えて出力します 3、「O列=vntData(j, 0) （入荷ID）」に就いては、確認の為「作業用」に「入荷ID」を抽出していますが データを持って来る配列には組入れてはいませんのでvntData(j, 0)は在りません、因ってエラーと成ります 今回の修正では、引数を追加して別の配列として取得しています
今回の追加変更でこの変数名を使っていますので確認して下さい また、使用順の件ですが、整列する前に文字列に変換して整列を行う様にし解決出来ると思います
「投入表」作成マクロの変更に就いて全文を載せる訳には行かないので新規のマクロ以外は 変更追加部のみ載せます(★印) 前後関係を善く見て追加変更して下さい（使用順の件も組み入れて在ります）
今までの「Public Sub Sample_3()」をSubルーティンプロシージャから引数を持ったFunctionプロシージャに変更します
「Public Sub Sample_3()」を「Private Function DrawUp(wksShip As Worksheet) As Boolean」に変更 「End Sub」を「End Function」に変更（自動的に行われるかも？） 変更した「Private Function DrawUp(wksShip As Worksheet) As Boolean」の中身の追加変更部（★印）
Dim vntStockID As Variant
Dim vntResult As Variant
Dim lngMax As Long
Dim rngSearch As Range '★追加
Dim vntSearch As Variant '★追加
Dim strForm As String '★追加
Dim blnLack As Boolean '★追加
Dim cnt As Long '★追加
Dim sagyoGrp() As Variant '★追加
Dim strProm As String
'作業用シートの抽出範囲の先頭セル位置(マスタから必要データを抽出)
Set rngWork = Worksheets("作業用").Range("A1")
'★「投入表」に書き込む「入荷マスタ」の探索Keyの基準先頭セル位置
Set rngSearch = rngResult.Parent.Range("O1") '★追加
'画面更新を停止
Application.ScreenUpdating = False
With rngSearch '★追加
'「入荷マスタ」更新データの行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row '★追加
'更新データの消去
If lngRows > 0 Then '★追加
If MsgBox("前回の更新が行われていません、このまま実行しますか？", _
vbInformation + vbYesNo + vbDefaultButton2) = vbYes Then '★追加
.Offset(1).Resize(lngRows, 2).ClearContents '★追加
Else '★追加
'※データ更新が行われていない場合、戻り値をTrueに
DrawUp = True '★追加
strProm = "マスタのデータ更新を行って下さい" '★追加
GoTo Wayout '★追加
End If '★追加
End If '★追加
End With '★追加
'投入表に就いて
With rngResult
'入荷マスターから必要データを取得
' If Not GetData(vntData, rngList, rngWork, vntStockID) Then
If Not GetData(vntData, rngList, rngWork, vntStockID, vntSearch) Then '★変更
strProm = "データの取得が出来ません、在庫ID、出庫場所等を確認して下さい"
GoTo Wayout
End If
'セル書式を取得
strForm = rngWork.Offset(1).NumberFormat '★追加
'入荷受付番号を転記
vntResult(k * 2 - 1) = "'" & vntData(j, 1)
'使用期限を転記
vntResult(k * 2) = GetDate(vntData(j, 4), vntData(j, 5), vntData(j, 6))
'★更新用データの転記位置を更新
cnt = cnt + 1 '★追加
'★更新用データを格納する配列を拡張
ReDim Preserve sagyoGrp(1 To 2, 1 To cnt)
'★更新用データ配列に「入荷ID」を転記
sagyoGrp(1, cnt) = vntSearch(j, 1)
If lngCount - vntData(j, 3) >= 0 Then '★追加
'★必要数より在庫が少ないか同じ場合
sagyoGrp(2, cnt) = vntData(j, 3) '★追加
Else '★追加
'★必要数より在庫が多い場合
sagyoGrp(2, cnt) = lngCount
End If '★追加
'必要数から在庫数を減算
lngCount = lngCount - vntData(j, 3)
End If
'結果を出力
rngResult.Offset(1, i).Resize(UBound(vntResult)).Value _
= WorksheetFunction.Transpose(vntResult)
'不足の場合の処理
If InStr(1, vntResult(k * 2 - 1), "枚不足") Then
rngResult.Offset(k * 2 - 1, i).Font.Color = vbRed
blnLack = True '★追加
End If
'出力の最大行数を保存
If lngMax < k Then
'入荷日、使用期限を書き込む
ReDim vntResult(1 To 2, 1 To 1)
vntResult(1, 1) = "入荷日"
vntResult(2, 1) = "使用期限"
For i = 0 To lngMax - 1
rngResult.Offset(i * 2 + 1).Resize(2).Value = vntResult
Next i
With rngSearch.Offset(1) '★追加
'★1列目のセル書式を抽出された列同じに設定
.Resize(cnt).NumberFormat = strForm '★追加
'★O～P列出力(配列の行列を入れ替えて)
.Resize(cnt, 2).Value = WorksheetFunction.Transpose(sagyoGrp) '★追加
End With '★追加
'在庫不足が生じているなら
If blnLack Then '★追加
strProm = "在庫不足が出ていますので更新データ消去されました" '★追加
rngSearch.Offset(1).Resize(cnt, 2).ClearContents '★追加
Else '★追加
strProm = "処理が完了しました"
'※データ更新が行われていない場合、戻り値をTrueに
DrawUp = True '★追加
End If '★追加
Wayout:
Set rngResult = Nothing
Set rngWork = Nothing
Set rngSearch = Nothing '★追加
以上
次に、以下のプロシージャに引数追加
Private Function GetData(vntData As Variant, rngList As Range, _
rngWork As Range, vntStockID As Variant) As Boolean
を
Private Function GetData(vntData As Variant, rngList As Range, _
rngWork As Range, vntStockID As Variant, vntSearch As Variant) As Boolean '★変更
と「vntSearch As Variant」と言う引数を追加します この引数が「作業用」から「入荷ID」を取得して来ます
その中の★印を変更追加
'作業用シートに就いて
With rngWork
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
GoTo Wayout
End If
'★使用期限（年、月、日）を文字列に変更
vntDate = .Offset(1, 4).Resize(lngRows, 3).Value '★追加
For i = 1 To lngRows '★追加
For j = 1 To 3 '★追加
If IsNumeric(vntDate(i, j)) Then '★追加
vntDate(i, j) = Right("00" & vntDate(i, j), 2) '★追加
End If '★追加
Next j '★追加
Next i '★追加
'★セル書式を文字列に変更
.Offset(1, 4).Resize(lngRows, 3).NumberFormat = "@" '★追加
'★文字列にした使用期限（年、月、日）をシート出力
.Offset(1, 4).Resize(lngRows, 3).Value = vntDate '★追加
'在庫ID順の使用期限（年、月、日）順の入荷日順でListを整列
'A列から整列する列の列Offsetを指定,全て昇順で
DataSort .Offset(1).Resize(lngRows, 11), Array(2, 4, 5, 6, 1), _
Array(xlAscending, xlAscending, xlAscending, _
xlAscending, xlAscending)
'全列データを配列に取得
vntData = .Offset(1, 1).Resize(lngRows + 1, 10).Value
'★配列に「入荷ID」を取得
vntSearch = .Offset(1).Resize(lngRows + 1).Value '★追加
End With
以上
以下、新規マクロ 次に「Private Function DrawUp(wksShip As Worksheet) As Boolean」を呼び出すプロシージャを追加 同じ標準モジュールに記述
Public Sub Main()
' 「投入表」作成マクロ
Dim wksObject As Worksheet
'作表する「投入表」シートを設定
Set wksObject = ActiveSheet
'「投入表」を作成してマスタ更新が行われていない場合
If DrawUp(wksObject) Then
'更新マクロを呼び出す
DataUpDate wksObject
End If
Set wksObject = Nothing
End Sub
以上 次に、マスタ更新マクロを作成 同じ標準モジュールに記述
Public Sub MasterUpDate()
' マスタ更新マクロ
DataUpDate ActiveSheet
End Sub
Private Sub DataUpDate(wksShip As Worksheet)
'「入荷マスタ」の探索Keyと成る列（基準セルからの列Offset:A列）
Const clngKey As Long = 0
'「入荷マスタ」の更新する列（基準セルからの列Offset:Q列）
Const clngItem As Long = 16
Dim i As Long
Dim lngFound As Long
Dim lngRows As Long
Dim rngList As Range
Dim rngResult As Range
Dim vntData As Variant
Dim vntValue As Variant
Dim strProm As String
'Listの先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngList = wksShip.Range("O1")
'結果出力の先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngResult = Worksheets("入荷マスター").Range("A3")
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = .Parent.Name & " は更新済みです"
GoTo Wayout
End If
'O～P列データを配列に取得
vntData = .Offset(1).Resize(lngRows, 2).Value
End With
'入荷マスタの更新確認
If MsgBox("入荷マスタの更新を行います、更新を行うと元には戻せません", _
vbInformation + vbOKCancel + vbDefaultButton2) = vbCancel Then
strProm = "マスタ更新を行わずに終了しました"
GoTo Wayout
End If
'画面更新を停止
Application.ScreenUpdating = False
With rngResult
'行数の取得
lngRows = .Offset(Rows.Count - .Row, clngKey).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = .Parent.Name & " にデータ行が有りません"
GoTo Wayout
End If
'念の為、「入荷マスタ」をA列をKeyとして昇順整列
DataSort Intersect(.CurrentRegion, .CurrentRegion.Offset(1)), Array(0), Array(xlAscending)
End With
'O列に就いて最終行まで繰り返し
For i = 1 To UBound(vntData, 1)
'※「入荷マスタ」のA列に「投入表」のO列が有るか探索(A列が文字列の場合）
lngFound = RowSearch(vntData(i, 1), rngResult.Offset(1, clngKey).Resize(lngRows))
'※「入荷マスタ」のA列に「投入表」のO列が有るか探索(A列が数値の場合）
' lngFound = RowSearch(CLng(vntData(i, 1)), rngResult.Offset(1, clngKey).Resize(lngRows))
'探索が失敗した場合、lngFoundに0が帰る
If lngFound > 0 Then
'データを更新
vntValue = rngResult.Offset(lngFound, clngItem).Value
rngResult.Offset(lngFound, clngItem).Value = vntValue - vntData(i, 2)
End If
Next i
'更新データを消去
With rngList
.Offset(1).Resize(UBound(vntData, 1), 2).ClearContents
End With
With rngResult
.Parent.Parent.Activate
.Parent.Activate
.Activate
End With
strProm = "マスタ更新処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function RowSearch(vntKey As Variant, _
rngScope As Range, _
Optional lngOver As Long) As Long
Dim vntFind As Variant
'Matchによる二分探索
vntFind = Application.Match(vntKey, rngScope, 1)
'もし、エラーで無いなら
If Not IsError(vntFind) Then
'もし、Key値と探索位置の値が等しいなら
If vntKey = rngScope(vntFind).Value Then
'戻り値として、行位置を代入
RowSearch = vntFind
End If
'Key値を超える最小値のある行
lngOver = vntFind + 1
Else
lngOver = 1
End If
End Function
以上
其々の実行は、「Sub Main」と「Sub MasterUpDate」で行います 尚、「入荷マスタ」のA列（入荷ID）が文字列の場合と数値の場合で「Sub DataUpDate」の中の
'※「入荷マスタ」のA列に「投入表」のO列が有るか探索(A列が文字列の場合）
lngFound = RowSearch(vntData(i, 1), rngResult.Offset(1, clngKey).Resize(lngRows))
'※「入荷マスタ」のA列に「投入表」のO列が有るか探索(A列が数値の場合）
lngFound = RowSearch(CLng(vntData(i, 1)), rngResult.Offset(1, clngKey).Resize(lngRows))
が違うので気を付けて下さい
尚、全部の追加変更が終わったら、VBEの「デバッグ」→「VBAProjectのコンパイル」を行い エラーが出たら、もう一度確認し修正、 再度「VBAProjectのコンパイル」を行いエラーが出なくなるまで此れを繰り返して下さい 次に、テストに際しマスタ等のバックアップを必ず取ってからテストして下さい
(Bun)
書き忘れました 「Private Sub DataSort」中ので 「DataOption:=xlSortTextAsNumbers '★変更」として下さいと言いましたが 「DataOption:=xlSortNormal」に戻して置いて下さい 戻さないと、結果は以前と変わらなく成ります
(Bun)
ありがとうございます。
コードを追加変更してコンパイルを行ってみましたが、
DrawUp = True
のところ全てで「配列には割り当てられません」というエラーが出ます。
検索してみたところ、例えば
Dim test() As String
とすべきところを
Dim test(10) As String
のようにしている場合に出る、ということが書いてあったので、
DrawUp(wksShip As Worksheet) As Boolean()
これを
Private Function DrawUp() As Boolean()
Dim wksShip As Worksheet
このように分割してみましたがやはり「配列には～」のエラーになります。
Boolean の部分を変えても同じエラーでした。
とりあえず
DrawUp = True
を全てコメントブロックにして再度コンパイルで
Private Function GetData(vntData As Variant, rngList As Range, _
rngWork As Range, vntStockID As Variant, vntSearch As Variant) As Boolean
で「vntDate」が定義されていないのエラーが出たので
Dim vntDate As Variant
を追加しました。
すると今度は Public Sub Main() If DrawUp(wksObject) Then これの「DrawUp」で「型が一致しません」のコンパイルエラーが出ます。 ここをとりあえず Dim DrawUp As Variant としてみました。
そこで「VBAProjectのコンパイル」がグレーアウトになったので実行してみたところ（DrawUp = True はコメントブロックのまま） やはり If DrawUp(wksObject) Then で「型が一致しません」のエラーになります。
ここのIFステートメントでどうしても止まるので先に進めません…
DrawUp の2つのエラーについてヒントでいいのでお教えください…
（雪だるま）
>コードを追加変更してコンパイルを行ってみましたが、 > > > DrawUp = True > > >のところ全てで「配列には割り当てられません」というエラーが出ます。
この「DrawUp」て何か解りますか？
「Public Sub Sample_3()」を「Private Function DrawUp(wksShip As Worksheet) As Boolean」に変更
して在ります ここでしたい事は、「Public Sub Sample_3()」と言うグローバル（どのモジュールからも参照可能）で 引数を持たないSubプロシージャを「Private Function DrawUp(wksShip As Worksheet) As Boolean」と言う モジュールレベル（此れが書かれているモジュールからだけ参照可能）で引数を持ったFunctionプロシージャに プロシージャ名を変更して下さいと言う事です Functionプロシージャは戻り値と言う物を呼び出し元に返します、例えばワークシート関数のSUM関数と同じです この場合、=SUM(B1:D1)と書かれますが括弧の中のB1:D1が引数でこの数式が書かれているセルに帰ってくる B1+C+D1の結果が戻り値と成ります 詰まり、「Private Function DrawUp(wksShip As Worksheet) As Boolean」は、DrawUp関数は引数に ワークシート型の変数wksShipを持ち、Boolean型の戻り値を返します 引数wksShipにワークシート持たせ此れを呼び出すと内部では、色々な処理を行い結果として関数名DrawUpに True若しくはFalseを戻り値として返します この戻り値を返す操作が「DrawUp = True」です 此処で、「配列には割り当てられません」と出てくるのは、Functionの定義で戻り値の型を指定している 「) As Boolean」が違っているのが原因だと思います
>DrawUp(wksShip As Worksheet) As Boolean() >これを
と書いて有りますが引数の型指定「) As Boolean」の後ろに「()」が有りますが此れを付けると 戻り値がBoolean型の配列と成ってしまいます、因って戻り値に配列を指定しなくてはならないのに ただのリテラル定数した為「配列には割り当てられません」と出ているのでしょう この「) As Boolean()」の後ろの「()」は必要在りません、書き変えの指示には入っていませんが？ 後ろの「()」削除し、書き換えの指示通りにして下さい、
2、 >Private Function GetData(vntData As Variant, rngList As Range, _ > rngWork As Range, vntStockID As Variant, vntSearch As Variant) As Boolean > >で「vntDate」が定義されていないのエラーが出たので > Dim vntDate As Variant >を追加しました。
ゴメン此れは私のミスです、言い訳を言わしていただければ、整列順の件の修正で「Dim vntDate As Variant」 の一行を入れたのですが、此れを追加指示に入れ忘れました 仰せの取り「Function GetData」の変数宣言部に追加して頂ければ結構です
3、 >すると今度は >Public Sub Main() > If DrawUp(wksObject) Then >これの「DrawUp」で「型が一致しません」のコンパイルエラーが出ます。 >ここをとりあえず Dim DrawUp As Variant としてみました。
此れも「1、」に起因します、DrawUpの戻り値がただのBoolean値（True、Falseの事）だからこの様な書き方をするのに >DrawUp(wksShip As Worksheet) As Boolean() と成っているので、コンパイラ様は「配列が戻って来るのに何でこんな書き方してるのよ」って怒ってイラシャルのです
兎に角、「Private Function DrawUp(wksShip As Worksheet) As Boolean」として、 「Dim vntDate As Variant を追加しました。」以外の指示外の変更を戻して下さい
(Bun)
ありがとうございます＆すみませんでした。
プロシージャの先頭をコピー＆ペーストする時に余計な部分を削除せずに貼りつけていたようです…
教えていただいた指示で書き換えたところ投入表作成・マスタ更新ともうまく行きました。
いくつかのデータで試したのですが、
商品A 1行目の在庫：2000 2行目の在庫：5000 セット数：3000
という時に、マスターの1行目の在庫の数値が「0」になる時と「-2000」となる時があるのですが、どういう条件でなっているのか 判別がまだつきません。 先日書きましたようにマスターを入力規則が統一されていなかったのでどこかが文字列だったり数値だったりしているのかも… 引き続きテストしながら運用に持っていきます。
本当にありがとうございました！
（雪だるま）
>いくつかのデータで試したのですが、 > >商品A >1行目の在庫：2000 >2行目の在庫：5000 >セット数：3000 > >という時に、マスターの1行目の在庫の数値が「0」になる時と「-2000」となる時があるのですが、どういう条件でなっているのか >判別がまだつきません。 >先日書きましたようにマスターを入力規則が統一されていなかったのでどこかが文字列だったり数値だったりしているのかも…
簡単なテストをして見ましたが上記と成る事例は確認されませんでしたが？
1つ、考慮していなかった事に気が付きました
此れは、マスタメンテナンスの成されていない等で、在庫数0やマイナス在庫が有った場合に就いてです
もしかすると此れに関係しているかも解りません
少し落ち着いてからにしようと思っていたのですが？
上記の様な事例が出て来ているので、この対策をします
対策方法は2案在ります
1、現在の「Function DrawUp」の中の在庫引当のLoopに、
If vntData(j, 3) > 0 Then
と入れて、在庫0若しくはマイナス在庫を無視する方法
この場合、追加は2行で済みますが処理が遅く成る可能性が有ります
2、修正は多く成りますが「作業用」に抽出する時点で抽出条件に在庫0を超える物と条件を増やして
その時点で在庫が0以下の物を除外する方法です
この場合、「Function DrawUp」の中の在庫引当のLoopで見る行が少なく成るので処理が速く成ります
其処で第2案方をお勧めします この場合の変更点は、 1、「作業用」シートにフィールドを追加します、場所は、O1セルです D1に在る「入荷実数」をO1セルにCopyして下さい 2、コードを変更します変更するのは「Function GetData」に成ります 一応、「Function GetData」の全文を載せますので差し替えて下さい 前回の変更部分も含んでいます
Private Function GetData(vntData As Variant, rngList As Range, _
rngWork As Range, vntStockID As Variant, _
vntSearch As Variant) As Boolean '★変更
' 入荷マスターからAdvancedFilterを使ってデータを取得
Dim i As Long
Dim j As Long
Dim vntCrit As Variant
Dim rngCrit As Range
Dim lngRows As Long
Dim vntDate As Variant '★追加
'作業用シートの条件範囲の先頭セル位置(マスタから必要データを抽出)
Set rngCrit = rngWork.Parent.Range("N1")
'在庫IDを抽出条件に出力 ★在庫数が0の場合の処理追加
' ReDim vntCrit(1 To UBound(vntStockID, 2), 1 To 1)
ReDim vntCrit(1 To UBound(vntStockID, 2), 1 To 2) '★変更
For i = 1 To UBound(vntStockID, 2)
vntCrit(i, 1) = "=" & """=" & vntStockID(1, i) & """"
vntCrit(i, 2) = "=" & """>0""" '★追加
Next i
' rngCrit.Offset(1).Resize(UBound(vntStockID, 2)).Value = vntCrit
rngCrit.Offset(1).Resize(UBound(vntStockID, 2), 2).Value = vntCrit '★変更
'入荷マスターから必要データを抽出
' DoFilter rngList.CurrentRegion, _
' rngCrit.Resize(UBound(vntStockID, 2) + 1), _
' rngWork.Resize(, 11)
DoFilter rngList.CurrentRegion, _
rngCrit.Resize(UBound(vntStockID, 2) + 1, 2), _
rngWork.Resize(, 11) '★変更
'作業用シートに就いて
With rngWork
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
GoTo Wayout
End If
'★使用期限（年、月、日）を文字列に変更
vntDate = .Offset(1, 4).Resize(lngRows, 3).Value '★追加
For i = 1 To lngRows '★追加
For j = 1 To 3 '★追加
If IsNumeric(vntDate(i, j)) Then '★追加
vntDate(i, j) = Right("00" & vntDate(i, j), 2) '★追加
End If '★追加
Next j '★追加
Next i '★追加
'★セル書式を文字列に変更
.Offset(1, 4).Resize(lngRows, 3).NumberFormat = "@" '★追加
'★文字列にした使用期限（年、月、日）をシート出力
.Offset(1, 4).Resize(lngRows, 3).Value = vntDate '★追加
'在庫ID順の使用期限（年、月、日）順の入荷日順でListを整列
'A列から整列する列の列Offsetを指定,全て昇順で
DataSort .Offset(1).Resize(lngRows, 11), Array(2, 4, 5, 6, 1), _
Array(xlAscending, xlAscending, xlAscending, _
xlAscending, xlAscending)
'全列データを配列に取得
vntData = .Offset(1, 1).Resize(lngRows + 1, 10).Value
'★配列に「入荷ID」を取得
vntSearch = .Offset(1).Resize(lngRows + 1).Value '★追加
End With
GetData = True
Wayout:
Set rngCrit = Nothing
End Function
以上
尚、本当は出庫場所も抽出条件に加えて抽出で絞り込めればもっと速く成るのですが？ 其れは、マスタのメンテナスが終わったら、雪だるまさんが考えて見て下さい
(Bun)
ありがとうございます。 今のところ順調にいってます。 本当にお手数をおかけしました。
（雪だるま）
一応動いて良かったですね ただ、結果の状態、運用上の不都合、データの更新状態等を良く確認して 本番の運用に供して下さいね
(Bun)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.