VBAで複数条件検索どうすればよいですか？

質問

【Sheet1】
発注日 　 品番 　　 ロットNo 　　　　　納品日
　　A　　　　 B　　　　　　C　　　　　　　　　　D
1　3/11　　553　　111-111-1111　　　3/17
2　3/11　　123　　222-222-2222
3　3/11　　223　　333-333-3333
4　3/12　　123　　444-444-4444　　　3/17
5　3/12　　553　　555-555-5555
【Sheet2】
　納品日　　品番 　 ロットNo
　　　A　　　　B　　　　　C
1 　3/17　　553　 111-111-1111
2 　3/17　　123 　444-444-4444
3　 3/17　　223 　666-666-6666

エクセル2010・VBAで、【Sheet2】の品番とロットNoの条件に合う行を【Sheet1】より探し、【Sheet1】D列に納品日を入力し、その行のロットNoを明るい緑で塗りつぶす。
【Sheet2】の条件が【Sheet1】にないなら【Sheet2】の行のロットNoを、赤で塗りつぶす。
【Sheet1】は発注リスト、【Sheet2】は納品リストになります。
納品日は検索した日の日付になります。
Findを使い試行錯誤しましたが、思うように動かず、スキル不足で困っています。どなたか、ご教授願います。宜しくお願い致します。

回答No.1

tom04 · ベストアンサー

こんばんは！
色々やり方はあると思いますが・・・
一例です。

＞納品日は検索した日の日付になります。

とありますが、とりあえずSheet2（納品リスト）のA列日付としています。
Sheet1（発注リスト）に重複があっても対応できるようにしてみました。
↓のコードを標準モジュールにコピー＆ペーストしてマクロを実行してみてください。

Sub Sample1()
Dim i As Long, k As Long, c As Range, wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("発注リスト")
Set wS2 = Worksheets("納品リスト")
Application.ScreenUpdating = False
i = wS1.Cells(Rows.Count, "A").End(xlUp).Row
Range(wS1.Cells(2, "D"), wS1.Cells(i, "D")).ClearContents
k = wS2.Cells(Rows.Count, "A").End(xlUp).Row
With wS1
.Cells.Interior.ColorIndex = xlNone
.Range("A:A").Insert
With .Range(wS1.Cells(2, "A"), wS1.Cells(i, "A"))
.Formula = "=C2 & ""_"" & D2"
.Value = .Value
End With
End With
With wS2
.Cells.Interior.ColorIndex = xlNone
.Range("A:A").Insert
With .Range(wS2.Cells(2, "A"), wS2.Cells(k, "A"))
.Formula = "=C2 & ""_"" & D2"
.Value = .Value
End With
End With

For k = 2 To wS2.Cells(Rows.Count, 1).End(xlUp).Row
Set c = wS1.Range("A:A").Find(what:=wS2.Cells(k, "A"), LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
wS2.Cells(k, "D").Interior.ColorIndex = 3
Else
For i = 2 To wS1.Cells(Rows.Count, "A").End(xlUp).Row
If wS1.Cells(i, "A") = wS2.Cells(k, "A") Then
With wS1.Cells(i, "E")
.Value = wS2.Cells(k, "B")
.NumberFormatLocal = "m/d"
End With
wS1.Cells(i, "D").Interior.ColorIndex = 4
End If
Next i
End If
Next k
wS1.Range("A:A").Delete
wS2.Range("A:A").Delete
Application.ScreenUpdating = True
End Sub

※　両SheetともA列を作業用の列として挿入していますので、
コードでは元データは1列ずつずれています。m(_ _)m

お礼

お礼遅くなりました。ありがとうございます。
＞両SheetともA列を作業用の列として挿入していますので・・・
この部分の動きが、手こずりましたが、大体の動きが理解できました。勉強になりました。
ありがとうございました。