評価の事務処理をマクロでできないでしょうか

質問

派遣切り後、事務職の就職がようやく見つかりました。
仕事の効率を少しでも上げて、より多くの業務処理をしたいので下記のマクロを作成したいと考えています。
１ヶ月前に書籍を購入して独自でできるか試したのですがダイレクトな情報が見つからず、基礎の部分だけはできたところです。
恐縮なのですがもし、できる方がいましたらぜひ教えて頂けませんでしょうか。

Sheet1とSheet2があります。
Sheet1は、A列には6桁の納品番号の羅列、B列は【空白】です。

Sheet2は、顧客からの評価が記載→A,B,C,空白：
A列には6桁の納品番号、B列は【評価】があります。

Sheet1例
●A列 B列
238062
238075
238096
238220
92528
238230
238090
*A列はMAX70行ほどあります

●Sheet2例
A列 B列
92528 B
238062 A
238075 C
238090 B
238096 A
238220 　←空白（記載無し）
238230 A
*A列はMAX500行ほどあります

したいことは、
1.Sheet1のA列にある6桁の納品番号を１つずつ検索
2.Sheet2のA列ににその納品番号があるかどうか？
3.Sheet2にその納品番号があれば、Sheet2のその納品番号の右隣(Sheet2のB列)の評価がA,B,C,空白　の何かを見ます
4.そして、Sheet1のB列にその評価を記載します。空白の場合はSheet1のB列のセルを赤くします。
Sheet2にはダブル数字がある可能性が有り、その場合はSheet1のB列のセルを緑色にします。
です。以下の「●Sheet1処理後の例」を参照ください。

●Sheet1処理後の例
A列 B列
238062 A
238075 C
238096 A
238220 セルを赤色にします
92528 B
238230 A
238090 B

回答No.1

ka_na_de · ベストアンサー

一例です。

だぶっている場合は、最後のデータを記入した上で緑にします。

Sub test02()
　　Dim Ws1 As Worksheet
　　Dim Ws2 As Worksheet
　　Dim myRange1 As Range
　　Dim myRange2 As Range
　　Dim c1 As Range
　　Dim c2 As Range
　　Dim myCt As Long

　　Set Ws1 = Worksheets("Sheet1")
　　Set Ws2 = Worksheets("Sheet2")
　　Set myRange1 = Ws1.Range("A1", Ws1.Cells(Rows.Count, "A").End(xlUp))
　　Set myRange2 = Ws2.Range("A1", Ws2.Cells(Rows.Count, "A").End(xlUp))

　　For Each c1 In myRange1
　　　　myCt = 0
　　　　For Each c2 In myRange2
　　　　　　If c2.Value = c1.Value Then
　　　　　　　　If c2.Offset(, 1).Value = "" Then
　　　　　　　　　　c1.Offset(, 1).Interior.ColorIndex = 3
　　　　　　　　Else
　　　　　　　　　　c1.Offset(, 1).Value = c2.Offset(, 1).Value
　　　　　　　　End If
　　　　　　　　myCt = myCt + 1
　　　　　　End If
　　　　Next c2
　　　　If myCt > 1 Then c1.Offset(, 1).Interior.ColorIndex = 10
　　Next c1

　　Set Ws1 = Nothing
　　Set Ws2 = Nothing
　　Set myRange1 = Nothing
　　Set myRange2 = Nothing
End Sub

お礼

100％私が欲しいマクロでした！
こんなに速く完璧な返信を頂いて感動して涙が出ました。
本当にありがとうございました。