• ベストアンサー

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

下記のマクロを作成しました。 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

質問者が選んだベストアンサー

  • ベストアンサー
  • ka_na_de
  • ベストアンサー率56% (162/286)
回答No.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

mika_mika_
質問者

お礼

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

その他の回答 (2)

  • hige_082
  • ベストアンサー率50% (379/747)
回答No.2

これを試してみてください 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 参考まで

mika_mika_
質問者

お礼

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

mika_mika_
質問者

補足

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

  • myRange
  • ベストアンサー率71% (339/472)
回答No.1

>WS1.Cells(RowPos, 1).Interior.ColorIndex = 6 この黄色の塗りつぶしに、該当セルが空白でなかったら、という条件を付ければいいですね?   If ws1.Cells(RowPos, 1) <> "" Then    ws1.Cells(RowPos, 1).Interior.ColorIndex = 6 End If それから、余計な一言。 Sheet2に該当する番号が複数あったら、最初のひとつしか赤になりませんが、それでいいのですね? 要するに、Sheet2にダブりの番号はないのか、ということです。 以上です。  

mika_mika_
質問者

お礼

ありがとうございます。 下記のようにしたのですが、エラーが出てしまいます。 なぜなのでしょうか。。。 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

関連するQ&A

専門家に質問してみよう