【ExcelVBA】増殖した条件付き書式を1本化して再設定するマクロ

条件付き書式が設定されたExcelファイルで作業をしていると、
どうしても条件付き書式が増殖してしまいます。

行の挿入や削除を行うと条件付き書式が途切れてしまい、
G13:G18、G19、G20:25、、、、と分裂・増殖してしまうアレですね。

↓見ただけで嫌になってくる設定画面
増殖した条件付き書式

対策として「書式設定をマクロ化にしておき都度設定し直す」方法もありますが、
それだとシートの数だけ個別のマクロが必要になってしまいます。

ということでこの修復を自動でやってくれるマクロを作ってしまいましょう！

仕様としては、

範囲内の第1行に設定された条件付き書式を残して、
2行目以降の書式をすべてクリアする
第1行に設定された条件付き書式を範囲全体へ広げ直す

という手順を踏んで書式を再設定するマクロです。

※ 「書式のコピー」を使用していませんので、
条件付き書式以外の通常書式が消えてしまうこともありません。

実行型の便利マクロですので、
Excel起動時に裏で開かれる「個人用マクロブック」などに搭載して使ってください。

ショートカットキーに登録したり、ツールバーやリボンにボタン配置すると便利です

ソースコード
解説

ソースコード

' 実行プロシージャ(選択範囲)
Sub 選択範囲の増殖条件付き書式を一本化する()
    Call 指定エリア内で増殖した各条件付き書式を第1行の書式を元にそれぞれ一本化する(Selection)
End Sub

' 実行プロシージャ(フィルター範囲)
Sub アクティブシートフィルター範囲の増殖条件付き書式を一本化する()
    If ActiveSheet.AutoFilterMode = False Then Exit Sub
    
    Dim フィルターデータ部 As Range
    Set フィルターデータ部 = ActiveSheet.AutoFilter.Range
    If フィルターデータ部.Rows.Count = 1 Then Exit Sub
    
    Set フィルターデータ部 = フィルターデータ部.Offset(1)
    Set フィルターデータ部 = フィルターデータ部.Resize(フィルターデータ部.Rows.Count - 1)
    
    Call 指定エリア内で増殖した各条件付き書式を第1行の書式を元にそれぞれ一本化する(フィルターデータ部)

End Sub

' メインプロシージャ
Sub 指定エリア内で増殖した各条件付き書式を第1行の書式を元にそれぞれ一本化する(指定エリア As Range)
    
    If 指定エリア.FormatConditions.Count = 0 Then Exit Sub
    
    ' 第1行以外の書式をいったんクリア
    指定エリア.Offset(1).Resize(指定エリア.Rows.Count - 1) _
        .FormatConditions.Delete
    
    ' 各条件書式をひとつずつループ
    Dim 書式No As Long
    For 書式No = 指定エリア.FormatConditions.Count To 1 Step -1
        Dim 各条件付き書式 As FormatCondition
        Set 各条件付き書式 = 指定エリア.FormatConditions(書式No)
            ' ※ For Eachで回すとExcelがフリーズする。
            ' 原因はModifyAppliesToRangeによってFormatConditionsコレクションが書き換わり、
            ' For Each中に対象コレクションの格納メモリに変更が発生するため
        
        ' 適用先を取得し、それをデータ行数分広げる
        Dim 現適用先 As Range: Set 現適用先 = 各条件付き書式.AppliesTo
        Dim データ行数 As Long: データ行数 = 指定エリア.Rows.Count
        
        ' 適用先が複数エリアの場合は各個ResizeしてUnionする必要あり
        Dim 新適用先 As Range: Set 新適用先 = Nothing
        Dim 現適用先各エリア As Range
        For Each 現適用先各エリア In 現適用先.Areas
        
            If 新適用先 Is Nothing Then
                Set 新適用先 = 現適用先各エリア.Resize(データ行数)
            Else
                Set 新適用先 = Union(新適用先, 現適用先各エリア.Resize(データ行数))
            End If
        
        Next
        
        ' 適用先を再設定 ※ 前述の通りこのコードはFor Each内で実行不可
        各条件付き書式.ModifyAppliesToRange 新適用先
        
    Next
    
End Sub

解説

前述の通り、一旦範囲内の2行目以降の条件付き書式をクリアし、
1行目の条件付き書式を範囲全体へ拡張するマクロです。

この手のマクロは「メインプロシージャをRangeを受け取って動く仕様にする」ことで、
実行マクロを複数パターン作ることが可能です。

今回は「手で選択した範囲に実行」版と「フィルター範囲自動実行版」の、
二つを作成しましたのでお好みでカスタマイズして使用して下さい。

肝心のコードは「FormatConditions」コレクションの中にある、
各条件付き書式を拡張しているだけのコードです。

単にResizeできればよかったのですが、
それだと「C列とF列に一括で設定された書式」などでエラーが起きてしまいます。

よって「いったんAreaごとにバラして、ResizeしてからUnionしなおす」手順を踏んでいます。

最後に、各条件付き書式をFor文でわざわざ回していますが、
コード内コメントの通り、以下のコードではExcelがフリーズします。

' これだとフリーズ
For Each 各条件付き書式 In 指定エリア.FormatConditions

' これはOK
For 書式No = 指定エリア.FormatConditions.Count To 1 Step -1
        Dim 各条件付き書式 As FormatCondition
        Set 各条件付き書式 = 指定エリア.FormatConditions(書式No)