Excel VBA 選択列の値が変わるごとに縞模様を付けるマクロ

2019年12月9日2022年4月4日

Excel マクロ、VBA

はじめに

上図のような表があるとして、A列(第1カテゴリ)の値が変わるごとに、セルに背景色を付けて色分けで見やすくしたい、ということはないだろうか。
↓のようなイメージだ。

このA列には、文字が昇順や降順で並んでいるという規則性などは全くないし、「研究」「イベント」といった文字が何回ずつ続くとかいう規則性も存在しない。

そういった規則や制約条件がない中、あくまで、<値が変わるごとに色を付ける>というだけのことがしたいのだ。

意外に難しい

これを、関数などExcelの一般機能で実現しようとすると、実は意外と難しくて一筋縄ではいかない。

強いてそれをやるなら、SUMPRODUCT関数とか小難しい関数を使うことになる。
SUMPRODUCT関数ってSUM関数みたいに数値の合計をする関数のはずだけど、一応そういう(どういう?)用途にも使える。

とはいっても私自身、そんな解法はスッと記述はできないし、やろうとも思わない。

理想は「条件付き書式」機能で、完全自動でA列の値が変わるごとに色が変わるようセットすることだ。
でもそれも、数式の設定とかが簡単ではないし、並べ替えとか行の削除とかにまで対応できるようにとか考えるとキリがない。

というわけで、Excelの標準機能でやろうとするとどうしても手間が掛かるばかりで見返りも少ないので、マクロでササッとやってしまうのが最良だと思う。

ソースコード

それでは、当該マクロのソースコードを書いてみる。

私はこのマクロを、個人用マクロブックに組み込んで使っている。

個人用マクロブックとかについては、ここを展開。

オリジナルのマクロをリボンに追加する方法はこちら。

個人用マクロブックについては、こちらやこちらで述べています。

Sub changeColorsPerEachValues()
'選択列の値が変わるごとに縞模様を付ける
    Dim selectRng	As Range
    Dim startR  	As Long
    Dim endR  		As Long
    Dim startC    	As Long
    Dim endC    	As Long
   
    Set selectRng = Selection
    startC = selectRng(1).Column '選択範囲の開始列
    endC = Cells(1, Columns.Count).End(xlToLeft).Column '選択範囲の終了列
    startR = selectRng(1).Row '選択範囲の開始行
    endR = Cells(Rows.Count, startC).End(xlUp).Row '選択範囲の縦方向の終端行
   
    Dim msg     As String
   
    msg = startC ＆ "列目の値が変わるごとに縞模様を付けますか？"
   
    If MsgBox(msg, vbQuestion + vbOKCancel, "確認") = vbCancel Then Exit Sub
   
    Application.ScreenUpdating = False '描画を省略
   
    Dim val00	As Variant
    Dim val01   As Variant
    Dim rng     As Range
    Dim r       As Long
    Dim flg     As Boolean
   
    val00 = Cells(startR, startC).Value '値0(前の行)
   
    For r = startR + 1 To endR
        val01 = Cells(r, startC).Value '値1(現在行)
        Set rng = Cells(r, 1).Resize(1, endC) '現在行全体
       
        '現在行の値が前の行と違うなら色付けフラグを逆に(0⇔1)
        If val01 ＜＞ val00 Then flg = -flg - 1
       
        With rng.Interior
            If flg Then
                .Pattern = xlNone '色無し
            Else '背景色を青にする
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 16775147
            End If
        End With
       
        '次のループにおける判定用にval00をセット
        val00 = Cells(r, startC).Value
    Next r
   
    Application.ScreenUpdating = True '描画を再開
End Sub