比較する2つのデータ内容が一致した場合、１つのデータに色を塗る方法について
解決したいこと
ここに解決したい内容を記載してください。
Excel VBAを使って、比較する２つのデータ内容が一致した場合、１つのデータに色を塗るマクロを作っています。
実装中に画像の部分でエラーが発生します。
データにはメールアドレス・所属部署・氏名・役職が含まれており、プログラムとしては下記の手順です。
１．別シートにある２つのデータを、新規作成したシートにそれぞれ貼り付ける（それぞれ最終行は可変する）。
２．左右のデータを、メールアドレスで付け合わせをする。
３．一致したメールアドレスが見つかった場合、左データのメールアドレスに赤塗りつぶし
ソースコードは、下記になります。
'１．新しいシートを作成
'先頭に追加
Worksheets.Add Before:=Sheets(1)
'２．新しいシートに、今月分データコピー
Dim LstRow3 As Long
'今月分未実施者データの最終行取得変数を定義
LstRow3 = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row
'最終行の取得
Worksheets(2).Range("B3:I" & LstRow3).Copy
'今月未実施者データのB3～I列最終行の取得
Worksheets(1).Activate
'追加した新しいシートを活性化
ActiveSheet.Range("B3").Select
'追加した新しいシートのB3セルを選択
Worksheets(1).Range("B3:I" & LstRow3).PasteSpecial xlPasteAll
'今月分未実施者データのB3～最終行を貼り付け
'３．新しいシートに、先月分データコピー
Dim LstRow4 As Long
'先月分未実施者データの最終行取得変数を定義
LstRow4 = Worksheets(4).Cells(Rows.Count, 1).End(xlUp).Row
'最終行の取得
Worksheets(4).Range("B3:I" & LstRow4).Copy
'先月未実施者データのB3～I列最終行の取得
Worksheets(1).Activate
'追加した新しいシートを活性化
ActiveSheet.Range("K3").Select
'追加した新しいシートのK3セルを選択
Worksheets(1).Range("K3:R" & LstRow4).PasteSpecial xlPasteAll
'今月分未実施者データのB3～最終行を貼り付け
Worksheets(1).Range("A1").Select
'４．２と３を比較し、メアドが一致したら今月分のメアドに赤塗りつぶし
Dim KongetsuRow As Variant
'D列メールアドレス側の範囲を定義
Dim SengetsutRow As Variant
'M列メールアドレス側の範囲を定義
Dim LastRowKongetsu As Long
'D列最終行を定義
Dim LastRowSengetsu As Long
'M列最終行を定義
Dim a As Long
Dim b As Long
LastRowKongetsu = Range("D4", AutoFilter.Range).Rows.Count '今月データの最終行までカウント
LastRowSengetsu = Range("M4", AutoFilter.Range).Rows.Count '先月データの最終行までカウント
KongetsuRow = Range("D4:D" & LastRowKongetsu)
SengetsuRow = Range("M4:M" & LastRowSengetsu)
For a = 4 To KongetsuRow '3行目から最終行まで反復処理する
For b = 4 To SengetsuRow
If Range(Cells(4.4), Cells(4, KongetsuRow)).Value = Range(Cells(13, 4), Cells(13, SengetsuRow)).Value Then '今月と先月でメアドが一致すれば
Rows(a).Interior.Color = RGB(255, 0, 0) 'その行を赤色にする
End If
Next b
Next a
試してみたこと
・メールアドレスではなく、データ全体としてメールアドレス・所属部署・氏名・役職で一致したものを左データの行に塗りつぶし
→左データのみならず、行全体が塗りつぶしされた
事象についてご回答いただければ幸いです。
よろしくお願いします。
0
