【Excel】【VBA】上下で列を比較し、同じであれば色を付ける

仕事中に書いたExcelマクロをメモ。

上下でセルを比較し、同じであれば色を付ける。このとき、連続する値が切り替わったとき、分かりやすいように赤と黄色で交互に色を付ける。例えば以下のような表があったとすると

処理後は以下のようになる。 aaaは連続するので黄色、その後bbbも連続しているが、上のaaaと区別しやすいように色を変える。 cccは連続しないので色付けなし。色は黄色、赤と切り替えていく。

ソースファイルは以下

Sub Macro1()
'上の行と比較して、列Aの値が同じであれば色を付けるマクロ
'連続する値が変わると、背景色を変える

    Dim coler As Integer      '色ﾌﾗｸﾞ
    Dim flg As Integer        '連続ﾌﾗｸﾞ
    Dim row As Long           '現在行
    
    Dim p_row_value As String '1行前のセルの値
    Dim n_row_value As String '現在行のセルの値
    
    '各変数の初期化
    p_row_value = ""
    n_row_value = ""
    coler = 0
    flg = 0
    
    '最終行まで繰り返す
    Dim i As Long
    For row = 1 To Cells(Rows.Count, 1).End(xlUp).row
    
        '現在行列Aの値を取得
        n_row_value = Cells(row, 1).Value
        
        '上の行と値が同じであれば色を付ける
        If n_row_value = p_row_value Then
               
            '連続が途切れた場合はｶﾗｰﾌﾗｸﾞを変更
            If flg = 0 Then
                '0なら1に、1なら0に
                coler = (coler + 1) Mod 2
            End If
                
        flg = 1  '連続ﾌﾗｸﾞON
            
        Cells(row - 1, 1).Interior.Color = f_coler(coler) '上の行B列の色を変更
        Cells(row, 1).Interior.Color = f_coler(coler)     '現在行B列の色を変更
           
        Else
           flg = 0  '連続ﾌﾗｸﾞOFF
        End If
        
        '現在行列Bの値をｾｯﾄ
        p_row_value = n_row_value
        
    Next row
    
    '完了表示
    MsgBox ("処理が完了しました。")

End Sub

Function f_coler(flg As Integer) As Long
    If flg = 0 Then
        'フラグが0であれば赤を返す
        f_coler = RGB(255, 0, 0)
    Else
        'フラグが1であれば黄を返す
        f_coler = RGB(255, 255, 0)
    End If
End Function

ちなみに、ループの条件は

For row = 1 To Cells(Rows.Count, 1).End(xlUp).row

列Aを最終行からさかのぼって、最初に値がある行まで。これで途中が空白セルで抜けてても、最終行までチェックできる。

ついでにもう一個。これはメモ。

Sub Macro2()

    Dim coler As Integer     '色
    Dim flg As Integer        '連続ﾌﾗｸﾞ
    Dim row As Long           '現在行
    Dim s_row As Long         '開始行
    Dim e_row As Long         '終了行
    
    Dim p_row_value As String '1行前のセルの値
    Dim n_row_value As String '現在行のセルの値
    
    Dim i As Long             'ﾙｰﾌﾟ用ｶｳﾝﾀ
    
    '各変数の初期化
    p_row_value = ""
    n_row_value = ""
    coler = 0
    flg = 0
    
    '最終行まで繰り返す
    For row = 1 To Cells(Rows.Count, 1).End(xlUp).row
        n_row_value = Cells(row, 1).Value
        
        '上の行と値が同じ時の処理
        If n_row_value = p_row_value Then
                
            '新たに連続が始まるときは連続の開始行を取得
            If flg = 0 Then
                coler = (coler + 1) Mod 2
                s_row = row - 1
            End If
            
            flg = 1  '連続ﾌﾗｸﾞON
        
        
        '上の行と値が違う時の処理
        Else
            '連続が途切れたら連続の終了行を取得し表示処理
            If flg = 1 Then
                e_row = row - 1 '終了行の取得
                Call s_check(s_row, e_row) '表示処理
            End If
            
            '1行だけの場合は列bの値を見て、Yなら列cにYYを表示
            If Cells(row, 2).Value = "Y" Then
                Cells(row, 3).Value = "YY"
            End If
            
            flg = 0  '連続ﾌﾗｸﾞOFF
            
        End If
        
        '現在行列Bの値をｾｯﾄ
        p_row_value = n_row_value
        
    Next row
    
    '完了表示
    MsgBox ("処理が完了しました。")

End Sub


Sub s_check(s As Long, e As Long)
'連続する行s〜eの列Eの値をチェックし、結果を列Hに表示する
'引数 s : 開始行
'引数 e : 終了行

    Dim i As Long
    Dim ii As Long
    Dim Yno As Long
    
    'Yが存在する行数の初期化
    Yno = 0
    
    行sから行eをチェック
    For i = s To e
        If Cells(i, 2).Value = "X" Then
        ElseIf Cells(i, 2).Value = "Y" Then
            'Yが存在すればその行数を保持
            Yno = i
        End If
    Next
    
    
    'Yが存在しなければ何もしない
    If Yno = 0 Then
    
    'Yが存在する行が最後
    ElseIf Yno = e Then
        For ii = s To e
            '行sから行eに削除を表示
            Cells(ii, 2) = "YY"
        Next ii
        
    'Yが存在する行が最後でない
    Else
        For ii = s To e
            '行sから行eにoutputを表示
            Cells(ii, 2) = "XX"
        Next ii
        
    End If
    
End Sub