全部黄色になってしまいます

質問

下記のマクロを作成しました。
1.Sheet1のA列の数字を１つずつ検索して、sheet2にその数字があれば、sheet2のそのセル赤くする。
全部あればすべてのセルが赤くなり、無いところがあれば白いままというマクロ
2.sheet1羅列を検索してsheet2に無い場合、逆にsheet1のその数字（検索してなかった数字）を黄色にする。
困っていることは、何も数字の無いところが全部黄色になってしまいます。
sheet1の空白のところは処理せずにそのまま白くあって欲しいのですがどのようにすればいいでしょうか？
●sheet1のA列に下記のような数字が羅列(200行程)しています。
238062
238075
238096
238210
91518
238230
123456
789123
456789
●sheet2のA列に下記のような数字が羅列しています。
91518
238062
238075
238096
238210

Sub 赤色付け()

Set WS1 = Worksheets("Sheet1")
Set WS2 = Worksheets("Sheet2")

Dim RowPos As Integer
Dim i As Integer

For RowPos = 1 To 200

If WorksheetFunction.CountIf(Range(WS2.Cells(1, 1), WS2.Cells(200, 1)), WS1.Cells(RowPos, 1)) > 0 Then
i = WorksheetFunction.Match(WS1.Cells(RowPos, 1), Range(WS2.Cells(1, 1), WS2.Cells(200, 1)), 0)
WS2.Cells(i, 1).Interior.ColorIndex = 3

ELSE
WS1.Cells(RowPos, 1).Interior.ColorIndex = 6

End If

Next

End Sub

回答No.3

ka_na_de · ベストアンサー

一例です。

Sub test01()
　　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 myCt = 0 Then
　　　　　　　　　　c2.Interior.ColorIndex = 3
　　　　　　　　Else
　　　　　　　　　　c2.Interior.ColorIndex = 10
　　　　　　　　End If
　　　　　　　　myCt = myCt + 1
　　　　　　End If
　　　　Next c2
　　　　If myCt = 0 Then c1.Interior.ColorIndex = 6
　　Next c1

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

お礼

最高です！
本当にありがとうございました！！

回答No.2

hige_082

これを試してみてください

Sub test()
Dim i, j
Dim WS1, WS2
Set WS1 = Worksheets("Sheet1")
Set WS2 = Worksheets("Sheet2")

For i = 1 To WS1.Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To WS2.Cells(Rows.Count, 1).End(xlUp).Row
If WS1.Cells(i, 1).Value = "" Then Exit For
If WS1.Cells(i, 1).Value = WS2.Cells(j, 1).Value Then
WS2.Cells(j, 1).Interior.ColorIndex = 3
Exit For
End If
Next j
If j > WS2.Cells(Rows.Count, 1).End(xlUp).Row Then
WS1.Cells(i, 1).Interior.ColorIndex = 6
End If
Next i

Set WS1 = Nothing
Set WS2 = Nothing
End Sub

参考まで

お礼

まさにおっしゃるとおりです！
Sheet2にダブりの番号はある可能性が有ります。
なので、ダブリが会った場合は
セルを緑色にするようにしたいのですが、どのようにすればいいでしょうか。

補足

ありがとうございます！
エラーが出ませんでした！！感謝です。
あと、Sheet2にダブりの番号はある可能性が有ります。
なので、ダブリがあった場合は
セルを緑色にするようにしたいのですが、どのようにすればいいでしょうか。。。
本当に質問ばかりで恐縮です・・・

回答No.1

myRange

>WS1.Cells(RowPos, 1).Interior.ColorIndex = 6

この黄色の塗りつぶしに、該当セルが空白でなかったら、という条件を付ければいいですね？

If ws1.Cells(RowPos, 1) <> "" Then
　　　ws1.Cells(RowPos, 1).Interior.ColorIndex = 6
End If

それから、余計な一言。
Sheet2に該当する番号が複数あったら、最初のひとつしか赤になりませんが、それでいいのですね？
要するに、Sheet2にダブりの番号はないのか、ということです。
以上です。

お礼

ありがとうございます。
下記のようにしたのですが、エラーが出てしまいます。
なぜなのでしょうか。。。
Sub 赤色付け()

Set ws1 = Worksheets("Sheet1")
Set WS2 = Worksheets("Sheet2")

Dim RowPos As Integer
Dim i As Integer

For RowPos = 1 To 200

If WorksheetFunction.CountIf(Range(WS2.Cells(1, 1), WS2.Cells(200, 1)), ws1.Cells(RowPos, 1)) > 0 Then
i = WorksheetFunction.Match(ws1.Cells(RowPos, 1), Range(WS2.Cells(1, 1), WS2.Cells(200, 1)), 0)
WS2.Cells(i, 1).Interior.ColorIndex = 3

Else
If ws1.Cells(RowPos, 1) <> "" Then
ws1.Cells(RowPos, 1).Interior.ColorIndex = 6

End If

Next

End Sub