Excelでデータの抽出＆別シート転記をマクロで行いたい(VBA) その2

先日、
https://oshiete.goo.ne.jp/qa/9954469.html
Excelでデータの抽出＆別シート転記をマクロで行いたい(VBA)

にてtatsu99様に希望がすべて叶うマクロを作成して頂きました。
全て手作業でしていた頃と比べると格段に時間短縮出来、
毎日苦痛だった作業が楽しみになりました。その節は誠にありがとうございました。

ただ…元リストの登録番号重複が想像していたよりも多く、
作成された手配リストでのデータの取捨選択にかなり時間がかかっている状況です。
そこで、下記機能を追加する方法をご教示願えませんでしょうか？
希望は(1)ですが、それが難しいようでしたら引き続き手作業でデータ削除する為に
(2)の機能を盛り込みたいです。

(1)注文表のB列(登録番号)&D列(登録番号に対するリストの商品名1行目の内容)が
一致した場合のみ抽出する。
例えば、登録番号1003は商品名の1行目がスリッパのものと軍手のものがありますが、
注文表のD列が軍手の場合、リスト9～12行目はスルーし21～22行目のみ抽出する
といった具合です。
また、リストC9･C10のように同一商品群で登録番号が複数ある場合も、
C10(1003)&G9(スリッパ)の組み合わせでチェックし同じことがしたいです。
登録番号も商品名(の1行目)も一致することはないと思うのですが、
可能性はゼロとは言えません…。
その場合に限りすべて抽出するといった動作は可能でしょうか？

(2)手配リスト作成時に登録番号に基づき一致するデータすべてを抽出しているので
商品名(C列)で商品群の境目がわからずデータの取捨選択に苦労しています。
添付画像の手配リストのように、手作業で不要行の削除をする際の目印になるよう
基準行＆重複行の一部セル(画像はB列C列)を塗りつぶしたいです。

ちなみに…シート名：リストは毎日最新の情報で更新されますので、その日限りのデータです。
手配リスト作成時に不要な行を削除したりセルに着色する等手を加えても全く問題はありません。

お時間のございます時にお力添えいただけたら幸いです。
どうぞよろしくお願いいたします。

質問者からの補足コメント

• 画像2を添付させて頂きます。

  
    補足日時：2017/10/01 22:32

• 1)注文表は全項目データベースから引っ張ってきますので手入力することはありません。
  「注文表D列は、正規の登録番号に対するリストの商品名1行目の内容が必ず設定されてる」
  ことは保障されています。
  
  2)tatsu99様のおっしゃる判定基準で問題ございません。
  ただ、そうなると登録番号重複の有無はチェックしない構造になるのでしょうか？
  登録番号も商品名一行目の内容も一致するケースがありますがその場合は判定基準通り全て抽出し、
  且つ基準行・重複行に着色するといった処理を希望しています。
  
  また、リストに自動入力されるのはF～H列のみでA～E列は人間が手入力していますので、
  入力作業中におかしな事をしてしまう可能性はゼロではありません…。
  万が一リストG列(商品名)と注文表D列(商品名)に一致するものがなければ、
  そうとわかるように途中でエラー処理(終了？)する事は可能でしょうか？

  No.1の回答に寄せられた補足コメントです。 補足日時：2017/10/02 21:40

No.4 回答者： tatsu99 回答日時： 2017/10/03 06:32

>2)tatsu99様のおっしゃる判定基準で問題ございません。

>ただ、そうなると登録番号重複の有無はチェックしない構造になるのでしょうか？
>登録番号も商品名一行目の内容も一致するケースがありますがその場合は判定基準通り全て抽出し、
>且つ基準行・重複行に着色するといった処理を希望しています。
回答：そのようにしました。
登録番号を２つ以上出力する場合、最初の登録番号の第一行の商品を赤、次の登録番号の第一行の商品を青にしています。
（それ以降の登録番号の第一行の商品は青になります）

また、リストに自動入力されるのはF～H列のみでA～E列は人間が手入力していますので、
入力作業中におかしな事をしてしまう可能性はゼロではありません…。
万が一リストG列(商品名)と注文表D列(商品名)に一致するものがなければ、
そうとわかるように途中でエラー処理(終了？)する事は可能でしょうか？
回答：そのようにしました。

No.3 回答者： tatsu99 回答日時： 2017/10/03 06:28

2回目

---------------------------------
'登録番号取得
Private Sub GetNumber()
Dim maxrow As Long
Dim maxrow2 As Long
Dim row As Long
Dim srow As Long
Dim erow As Long
srow = 0
'C列とF列の大きい方を最終行番号とする
maxrow = sh1.Cells(sh1.Rows.Count, "F").End(xlUp).row
maxrow2 = sh1.Cells(sh1.Rows.Count, "C").End(xlUp).row
If maxrow2 > maxrow Then maxrow = maxrow2
For row = 2 To maxrow
'登録番号の開始位置検知
If sh1.Cells(row, "A").Value <> "" Then
Call CheckRow(row, 2, 8) '行チェック
Call makeDict(srow, row - 1) '登録番号の辞書登録（空白行がない場合の保険）
srow = row
End If
'登録番号の終了位置検知
If sh1.Cells(row, "C").Value = "" And sh1.Cells(row, "F").Value = "" Then
Call makeDict(srow, row - 1) '登録番号の辞書登録
srow = 0
End If
Next
Call makeDict(srow, row - 1) '（空白行がない場合の保険）
End Sub
'登録番号の辞書登録
Private Sub makeDict(ByVal srow As Long, ByVal erow As Long)
Dim row As Long
Dim key As Variant
Dim r_erow As Long '商品の最後の行
If srow = 0 Then Exit Sub
For row = srow To erow
If Trim(sh1.Cells(row, "F").Value) = "" Then '修正①
Exit For
End If
r_erow = row
Call CheckRow(row, 6, 8) '行チェック
Next
For row = srow To erow
If sh1.Cells(row, "C").Value <> "" Then
key = sh1.Cells(row, "C").Value
Call CheckRow(row, 4, 5) '行チェック
If dicT.exists(key) = True Then
If errmsg = "" Then errmsg = "登録番号重複" & vbLf
errmsg = errmsg & "登録番号=" & key & "　基準行=" & dicT(key) & "　重複行=" & row & vbLf
dicS(key) = dicS(key) & "|" & srow
dicE(key) = dicE(key) & "|" & r_erow
Else
dicT(key) = row
dicS(key) = srow
dicE(key) = r_erow
End If
End If
Next
End Sub
'行チェック
Private Sub CheckRow(ByVal row As Long, ByVal scol As Long, ByVal ecol As Long)
Dim col As Long
For col = scol To ecol
If sh1.Cells(row, col) = "" Then
MsgBox ("リストの" & row & "行が不正　" & col & "列が空白です")
sh1.Activate
sh1.Cells(row, col).Select
End
End If
Next
End Sub

No.2 回答者： tatsu99 回答日時： 2017/10/03 06:27

文字数オーバーなので2回に分けます。

（1回目）
------------------------------------------
Option Explicit
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim dicT As Object '登録番号の出現行を保持
Dim dicS As Object '登録番号に一致する商品の開始行を保持（|で区切って複数もつ）
Dim dicE As Object '登録番号に一致する商品の終了行を保持（|で区切って複数もつ）
Dim errmsg As String
Public Sub 手配書作成()
Set sh1 = Worksheets("リスト")
Set sh2 = Worksheets("注文表")
Set sh3 = Worksheets("手配リスト")
Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Set dicS = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Set dicE = CreateObject("Scripting.Dictionary") ' 連想配列の定義
errmsg = ""
'リストを読み込み登録番号の連想配列を作成する
Call GetNumber
'注文表を読み込み手配リストを作成
Call Tehai
'重複番号のエラーを表示
If errmsg <> "" Then
MsgBox (errmsg)
End If
MsgBox ("処理完了")
End Sub
'手配リスト作成
Private Sub Tehai()
Dim maxrow As Long
Dim row1 As Long
Dim row2 As Long
Dim row3 As Long
Dim i As Long
Dim key As Variant
Dim srows As Variant
Dim erows As Variant
Dim ctr As Long '手配書へ出力した登録番号件数
Dim top_ix As Long '手配書出力した登録番号の最初の添え字
Dim color As Long
'手配リスト２行目以降をクリア
sh3.Activate
maxrow = sh3.Cells(sh1.Rows.Count, "A").End(xlUp).row
sh3.Range("A2:F" & maxrow).Value = ""
sh3.Range("B2:C" & maxrow).Select
Selection.Interior.Pattern = xlNone
row3 = 2
maxrow = sh2.Cells(sh1.Rows.Count, "A").End(xlUp).row
For row2 = 2 To maxrow '2行～最後の行まで繰り返す
key = sh2.Cells(row2, "B").Value
If dicT.exists(key) = False Then
MsgBox ("注文表の登録番号がリストになし　行番号=" & row2 & "　登録番号=" & key)
sh2.Activate
sh2.Cells(row2, "B").Select
End
End If
ctr = 0
top_ix = -1
'登録番号に対応する商品の開始行と終了行を取得
srows = Split(dicS(key), "|")
erows = Split(dicE(key), "|")
For i = 0 To UBound(srows) '複数の登録番号分繰り返す（出力対象の登録番号の件数をカウント）
If sh2.Cells(row2, "D").Value = sh1.Cells(CLng(srows(i)), "G").Value Then
If ctr = 0 Then top_ix = i
ctr = ctr + 1
End If
Next
For i = 0 To UBound(srows) '複数の登録番号分繰り返す
If sh2.Cells(row2, "D").Value = sh1.Cells(CLng(srows(i)), "G").Value Then
For row1 = CLng(srows(i)) To CLng(erows(i)) '商品の数分繰り返す
sh3.Cells(row3, "A").Value = sh2.Cells(row2, "A").Value '受注日
sh3.Cells(row3, "B").Value = sh2.Cells(row2, "B").Value '登録番号
sh3.Cells(row3, "C").Value = sh1.Cells(row1, "G").Value '商品名
sh3.Cells(row3, "D").Value = sh1.Cells(row1, "H").Value '個数
sh3.Cells(row3, "E").Value = sh2.Cells(row2, "C").Value '注文数
sh3.Cells(row3, "F").Value = sh3.Cells(row3, "D").Value * sh3.Cells(row3, "E").Value '合計(個数×注文数)
'2件以上の同一登録番号を出力する場合
If ctr > 1 Then
'最初の出力行は赤、以降は青
If row1 = CLng(srows(i)) Then
color = 15773696
If i = top_ix Then color = 255
sh3.Range("B" & row3 & ":C" & row3).Select
Selection.Interior.color = color
End If
End If
row3 = row3 + 1
Next
End If
Next
'手配リストに出力されなかった場合
If ctr = 0 Then
MsgBox ("注文表の商品名がリストになし　行番号=" & row2 & "　登録番号=" & key & " 商品名=" & sh2.Cells(row2, "D").Value)
sh2.Activate
sh2.Cells(row2, "D").Select
End
End If
Next
End Sub

この回答へのお礼

tatsu99様
お世話になっております。
昨日はありがとうございました！
別業務で忙しくまだ動作確認出来ていないのですが(汗)、
こちらの面倒な要望に全てご対応いただき大変感謝致しております。
また、テスト後にご報告させて頂きますのでよろしくお願い申し上げます。

お礼日時：2017/10/04 10:12

No.1 回答者： tatsu99 回答日時： 2017/10/02 15:00

1)その注文表のD列は人間が手入力するものなのでしょうか。

もし、そうだとすると、
登録番号に対するリストの商品名1行目の内容が「スリッパ」で登録されているとき、
「ｽﾘｯﾊﾟ」と半角で入力してしまったり、「スリッパ□」（□は全角の空白）と入力してしまうことはないですか。
もし、あるとすると、本来は、それを採用すべきですが、商品名1行目の内容に不一致なので、その注文は削除されてしまいます。
このようなことは考慮しなくて良いのでしょうか。
そのようなリスクがあるなら（２）案の基準行＆重複行の一部セルの塗りつぶしのほうが良いと考えます。

２）もし、「注文表のD列は、正規の登録番号に対するリストの商品名1行目の内容が必ず設定されてる」ことが保障されているなら
「注文表のD列の内容が、該当登録番号に対するリストの商品名1行目の内容に一致した場合のみ抽出する」
ことは可能です。
その場合は、登録番号が重複しているかいないかに関係なく、上記の基準で行われます。
（基準行の登録番号にも、重複行の登録番号にも上記の判定が適用されます）
（又、重複した登録番号をもたない登録番号にも上記の判定が適用されます）
（又、C9、C10のようなケースの登録番号のどちらにも上記の判定が適用されます）
上記の条件でよろしいでしょうか。

この回答へのお礼

tatsu99様、大変お世話になっております。
度々の質問にもかかわらずご回答下さいましてありがとうございます。
面倒な希望ばかりとなってしまい大変恐縮ですがよろしくお願いいたします。

お礼日時：2017/10/02 21:39