個人事業主の方必見!確定申告のお悩み解決

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

このQ&Aに関連する最新のQ&A

A 回答 (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
    • good
    • 0
この回答へのお礼

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

お礼日時:2010/04/02 21:56

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



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にダブりの番号はある可能性が有ります。
なので、ダブリがあった場合は
セルを緑色にするようにしたいのですが、どのようにすればいいでしょうか。。。
本当に質問ばかりで恐縮です・・・

補足日時:2010/04/02 21:26
    • good
    • 0
この回答へのお礼

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

お礼日時:2010/04/02 21:21

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



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

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


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

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

お礼日時:2010/04/02 21:11

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!


人気Q&Aランキング