- ベストアンサー
全部黄色になってしまいます
下記のマクロを作成しました。 1.Sheet1のA列の数字を1つずつ検索して、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
- みんなの回答 (3)
- 専門家の回答
質問者が選んだベストアンサー
一例です。 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
その他の回答 (2)
- hige_082
- ベストアンサー率50% (379/747)
これを試してみてください 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にダブりの番号はある可能性が有ります。 なので、ダブリがあった場合は セルを緑色にするようにしたいのですが、どのようにすればいいでしょうか。。。 本当に質問ばかりで恐縮です・・・
- myRange
- ベストアンサー率71% (339/472)
>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
お礼
最高です! 本当にありがとうございました!!