LoginSignup
MichelMichel
@MichelMichel

Are you sure you want to delete the question?

If your question is resolved, you may close it.

Leaving a resolved question undeleted may help others!

We hope you find it useful!

比較する2つのデータ内容が一致した場合、1つのデータに色を塗る方法について

解決したいこと

ここに解決したい内容を記載してください。

Excel VBAを使って、比較する2つのデータ内容が一致した場合、1つのデータに色を塗るマクロを作っています。
実装中に画像の部分でエラーが発生します。

データにはメールアドレス・所属部署・氏名・役職が含まれており、プログラムとしては下記の手順です。

1.別シートにある2つのデータを、新規作成したシートにそれぞれ貼り付ける(それぞれ最終行は可変する)。
2.左右のデータを、メールアドレスで付け合わせをする。
3.一致したメールアドレスが見つかった場合、左データのメールアドレスに赤塗りつぶし

ソースコードは、下記になります。

'1.新しいシートを作成
    '先頭に追加
    Worksheets.Add Before:=Sheets(1)

'2.新しいシートに、今月分データコピー
    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~最終行を貼り付け
       
    

'3.新しいシートに、先月分データコピー
    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
    
    
'4.2と3を比較し、メアドが一致したら今月分のメアドに赤塗りつぶし
    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


試してみたこと
・メールアドレスではなく、データ全体としてメールアドレス・所属部署・氏名・役職で一致したものを左データの行に塗りつぶし
→左データのみならず、行全体が塗りつぶしされた


事象についてご回答いただければ幸いです。
よろしくお願いします。

画像1.png
画像2.png

0

1Answer

LastRowKongetsu = Range("D4", AutoFilter.Range).Rows.Count

Rangeに2つ目の引数を指定できないためです。

シート内のセル構成が分からないので、対処法につてはお答えできません。
必要なら、シートのハードコピー(スクショ)等を提供してください。

0Like

Your answer might help someone💌