VBAサンプル集
増殖した条件付き書式を整理統合する

ExcelマクロVBAの実用サンプル、エクセルVBA集と解説
最終更新日:2020-01-06

増殖した条件付き書式を整理統合する


コピペによって条件付き書式は際限なく増加していきます。
あまり増えすぎると、Excelの動作が遅くなる場合もありますし、条件や書式を変更したい時にも困ることになります。
このような場合は、条件付き書式を消して再設定するしかなくなります、


これを解決するVBAを考えてみました。

条件付き書式の増殖に関する、Microsoft サポート

Excel 2007 条件付き書式をコピーした場合、以前より条件付き書式が増加する

こちらのページは結構有名かもしれないので、見たことのある人もいるかもしれません。
2007で変更になった仕様によるとの言い訳は仕方ないとして、
回避策が書かれていますが、

回避策
条件付き書式の増加により動作が遅くなった場合、 以下の手順で条件付き書式を削除後、条件付き書式を再度設定します。
[ホーム] タブの [ルールのクリア]-[シート全体からルールをクリア] を選択します。
同じ条件を設定するセルを適宜選択し、条件付き書式を設定します。


これは回避策ではなく、事後処理(というか事故処理)ですよね。
状況
この動作は仕様です。

最後は言い切りましたね。
その潔さは認めます。
そうです、ソフト作成において最終最後の言葉です。

増殖した条件付き書式の実例と対応

VBA マクロ 条件付き書式

右のスクロールバーを見てもらえれば分かる通り、
こうなってしまっては、手作業での修正は諦めた方が良いでしょう。

VBA マクロ 条件付き書式

全て削除してから再度条件付き書式を設定するか、
1行だけ残して(2行目を残すなら、3行目から最下行まで選択して)、ルールをクリアして、
2行目の条件付き書式の適用範囲を変更します。

これをVBAにするのは簡単です。
自動記録でも十分でしょう、セル範囲くらいを変更すれば使えます。

しかし、
行方向・列方向に飛び飛びの範囲に設定されていたりすると、もうお手上げになります。

ちなみに、条件付き書式が設定されているセルを全て選択するには、
ジャンプ(Ctrl+G)→セル選択

VBA マクロ 条件付き書式

簡単なVBAでの対応

全ての条件付き書式をクリアして再設定

Sub sample1()
  With Worksheets("Sheet1").Range("A1:A10")
    .FormatConditions.Delete
    .FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, Formula1:="90%"
    .FormatConditions(1).Interior.Color = vbRed
    .FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, Formula1:="100%"
    .FormatConditions(2).Interior.Color = vbYellow
  End With
End Sub

マクロの自動記録で作成されたVBAを変更すれば簡単に作成できま。

2行目の条件付き書式だけ残しクリア後に、2行目の適用範囲を変更

Sub sample2()
  Dim ws As Worksheet
  Dim fObj As Object
  Dim i As Long
  Set ws = ActiveSheet
  ws.Range("3:1000").FormatConditions.Delete
  For i = ws.Rows(2).FormatConditions.Count To 1 Step -1
    Set fObj = ws.Rows(2).FormatConditions(i)
    fObj.ModifyAppliesToRange fObj.AppliesTo.Resize(999)
  Next
End Sub

For Eachで処理したVBAコードを試して見たところ、
同一セル範囲に同一条件付き書式があるような特殊な場合、
Excelが落ちてしまう事がありました。

このVBAコードであれば問題ないと思いますが、
使う時には、必ずバックアップしてから実行する等の注意をしてください。

VBAの条件付き書式の基本については、
マクロVBA入門:第91回.条件付き書式(FormatCondition)
条件付き書式は、シート上で設定しておいた方が良いのですが、事前に設定しておけない場合は、VBAで条件付き書式を設定します。VBAで条件付き書式を設定する場合は、セル(Rangeオブジェクト)のFormatConditionsコレクションにFormatConditionオブジェクトを追加することで行います。
こちらを参考にしてください。

VBAで条件付き書式を整理統合した結果

この後に掲載してあるVBAであれば、上の画像の条件付き書式が、このように整理統合されます。

VBA マクロ 条件付き書式

1行目は、歯抜けの範囲に同じ条件付き書式が設定されていたようです。
これは、私が実際に使っているExcelですが、行挿入して書式が抜けている行があったという事です。
ここまで統合されれば、設定漏れも分かりますし、手作業で直すも簡単です。

こんなVBAが欲しかったという人が多くいるのではないかとの思いで作成してみました。
私自身が、このVBAによって今後の作業がかなり楽になると思っています。

今回のVBAコードの発想について

この仕様については、私も結構悩まされてきました。
手作業で、幾度となく条件付き書式を再設定してきました。
頻繁に発生するシートの場合は、
先に示したようなVBAで、
条件付き書式を削除して再設定できるようにマクロを用意しておいたりして対処してきました。

常々、この仕様は困ったものだとの思いと、なんとか出来ないものかとの思いは持っていました。

最近も条件付き書式が増加しているシートがあったので、手作業で再設定していて、
「これ、なんとか出来ないかなー、出来ないことないはずだよなー」、と思い立ち、
いろいろ考えてみたのですが、これがかなり難しい。

・何をもって、増殖してしまった条件付き書式と判定するのか
・何をもって、同じ条件付き書式と判定するのか

VBAコードのプログラミング以前に、仕様を決定出来ないのです。
頭を整理して、良く考えてみました。
問題は、
数式が同じかどうか・・・

数式が同じかどうかの判定

適用先:=$A$1:$A$10
VBA マクロ 条件付き書式

適用先:=$A$11:$A$20
VBA マクロ 条件付き書式

この2つの条件付き書式は同じものです。
コピペで作ったものです。

セル範囲の条件付き書式では、多くの数式は相対参照で書かれています。
つまり、コピーで増えた条件付き書式の数式は、コピペ先のセル参照に変更されています。

条件付き書式が設定されているセルと、数式が参照しているセルの位置関係が同じかどうか、
そんな判定をどのようにしたら良いのか・・・

当初は、
同じセルにコピペして、その数式が同じなら同じ数式ではないか!
このように考えてVBAを作成して公開しましたが、
しかし、この記事をお読みになった方からより良い情報をいただきました。
数式をR1C1形式に変換して比較
確かに、言われてみればその通りで、
条件付き書式の適用範囲の先頭セルを起点としたR1C1形式で比較すれば数式の同一性が判定できます。
そして、数式をR1C1形式に変換するには、ApplicationのConvertFormulaメソッドを使います。

また、分断されているセル範囲を連続セル範囲へ変換する方法も、
単純にUnionするだけだったものを力業で統合していたので改修しました。
さらに、全VBAを見直し、プロシージャーの単位も変更しました。
結果として、大幅に簡易なVBAになったと思います。

Application.ConvertFormulaメソッド

A1およびR1C1参照スタイルの間の数式でのセル参照を、相対参照と絶対参照の間、またはその両方に変換します。

Application.ConvertFormula (Formula, FromReferenceStyle, ToReferenceStyle, ToAbsolute, RelativeTo)

名前 必須 説明
Formula 必須 変換する数式を含む文字列を指定します。
必ず有効な数式を指定し、数式の先頭には等号 (=) を付けてください。
FromReferenceStyle 必須 変換前の参照形式を、XlReferenceStyleの定数で指定します。
ToReferenceStyle 省略可 取得する参照スタイルを指定するXlReferenceStyleの定数です。
この引数を省略すると参照形式は変更されず、引数FromReferenceStyleで指定された形式が使用されます。
ToAbsolute 省略可 変換された参照型を指定するXlReferenceTypeの定数です。
この引数を省略すると、参照の種類は変更されません。
RelativeTo 省略可 1 つのセルを含むRangeオブジェクトを指定します。
このセルは、相対参照の基点となります。

増殖した条件付き書式を整理統合するVBA

Option Explicit

'条件付き書式を格納する構造体
Type tFormat
  AppliesTo As String '適用範囲
  Formula1 As String '数式1
  Formula2 As String '数式2
  Operator As String '演算子
  NumberFormat As String '表示形式
  FontBold As String '太字
  FontColor As String '文字色
  InteriorColor As String '塗りつぶし色
  '追加判定したいプロパティはここに追加
End Type

Public Sub UnionFormatConditions(ByVal ws As Worksheet, _
                 Optional ByVal NewName As String = "")
  '条件付き書式を格納する構造体配列
  Dim fAry() As tFormat
  
  '条件付き書式が無い場合は終了
  If ws.Cells.FormatConditions.Count = 0 Then Exit Sub
   
  'オプションにより元シートをコピー
  If NewName <> "" Then
    ws.Copy After:=ws
    Set ws = ActiveSheet
    ws.Name = NewName 'シート名のチェックは省略しています。
  End If
  
  '条件付き書式を構造体配列へ格納
  Call SetFormatToType(fAry, ws)
  
  '同一条件付き書式の結合:配列内でセル範囲指定文字列を結合
  Call JoinAppliesTo(fAry, ws)
  
  '条件付き書式の統合:配列内のAppliesをFormatConditionに適用
  Call ModifyApplies(fAry, ws)
End Sub

'条件付き書式を構造体配列へ格納
Private Sub SetFormatToType(ByRef fAry() As tFormat, _
              ByVal ws As Worksheet)
  Dim i As Long
  Dim fObj As FormatCondition
  On Error Resume Next '.Formula2が取得できない場合の対処
  
  ReDim fAry(ws.Cells.FormatConditions.Count)
  For i = 1 To ws.Cells.FormatConditions.Count
    Set fObj = ws.Cells.FormatConditions(i)
    fAry(i).AppliesTo = fObj.AppliesTo.Address
    fAry(i).Formula1 = fObj.Formula1
    fAry(i).Formula2 = fObj.Formula2
    fAry(i).Operator = fObj.Operator
    fAry(i).NumberFormat = fObj.NumberFormat
    fAry(i).FontBold = fObj.Font.Bold
    fAry(i).FontColor = fObj.Font.Color
    fAry(i).InteriorColor = fObj.Interior.Color
    '追加判定したいプロパティはここに追加
    
    '数式エラーの条件付き書式は削除をする
    If isErrorFormula(fAry(i).Formula1) Or _
      isErrorFormula(fAry(i).Formula1) Then
      fAry(i).AppliesTo = ""
    End If
  Next
End Sub

'条件付き書式の数式エラー判定
Private Function isErrorFormula(ByVal sFormula As String) As Boolean
  If IsError(Evaluate(sFormula)) Then
    isErrorFormula = True
  Else
    isErrorFormula = False
  End If
End Function

'同一条件付き書式の結合:配列内でセル範囲指定文字列を結合
Private Sub JoinAppliesTo(ByRef fAry() As tFormat, _
              ByVal ws As Worksheet)
  Dim i1 As Long, i2 As Long
  For i1 = 1 To UBound(fAry)
    For i2 = 1 To i1 - 1
      '計算式1,2、文字色、塗りつぶしの一致判定
      If isMatchFormat(fAry(i1), fAry(i2), ws) Then
        fAry(i2).AppliesTo = Union(Range(fAry(i2).AppliesTo), _
                      Range(fAry(i1).AppliesTo)).Address
        fAry(i1).AppliesTo = ""
        Exit For
      End If
    Next
  Next
End Sub

'計算式1,2、演算子、文字色、塗りつぶしの一致判定
Private Function isMatchFormat(ByRef fAry1 As tFormat, _
                ByRef fAry2 As tFormat, _
                ByVal ws As Worksheet) As Boolean
  If fAry1.AppliesTo = "" Or _
    fAry2.AppliesTo = "" Then
    Exit Function
  End If
  
  Dim sFormula1 As String, sFormula2 As String
  isMatchFormat = True
  
  '計算式1
  sFormula1 = ToR1C1(fAry1.Formula1, fAry1.AppliesTo)
  sFormula2 = ToR1C1(fAry2.Formula1, fAry2.AppliesTo)
  If sFormula1 <> sFormula2 Then isMatchFormat = False
  
  '計算式2
  sFormula1 = ToR1C1(fAry1.Formula2, fAry1.AppliesTo)
  sFormula2 = ToR1C1(fAry2.Formula2, fAry2.AppliesTo)
  If sFormula1 <> sFormula2 Then isMatchFormat = False
  
  '演算子
  If fAry1.Operator <> fAry2.Operator Then isMatchFormat = False
  
  '表示形式
  If fAry1.NumberFormat <> fAry2.NumberFormat Then isMatchFormat = False
  
  '太字
  If fAry1.FontBold <> fAry2.FontBold Then isMatchFormat = False
  
  '文字色
  If fAry1.FontColor <> fAry2.FontColor Then isMatchFormat = False
  
  '塗りつぶし
  If fAry1.InteriorColor <> fAry2.InteriorColor Then isMatchFormat = False
  
  '追加判定したいプロパティはここに追加
End Function

'A1形式をR1C1形式に変換
Private Function ToR1C1(ByVal sFormula As String, _
               ByVal sAppliesTo As String)
  If sFormula = "" Then Exit Function
  Dim rng As Range
  Set rng = Range(sAppliesTo)
  ToR1C1 = Application.ConvertFormula(sFormula, xlA1, xlR1C1, , rng.Item(1))
End Function

'条件付き書式の統合:配列内のAppliesをFormatConditionに適用
Private Sub ModifyApplies(ByRef fAry() As tFormat, _
             ByVal ws As Worksheet)
  Dim i As Long
  Dim fObj As Object
  For i = ws.Cells.FormatConditions.Count To 1 Step -1
    Set fObj = ws.Cells.FormatConditions(i)
    If fAry(i).AppliesTo = "" Then
      fObj.Delete
    Else
      If fObj.AppliesTo.Address <> ws.Range(fAry(i).AppliesTo).Address Then
        fObj.ModifyAppliesToRange ws.Range(fAry(i).AppliesTo)
      End If
    End If
  Next
End Sub
  

同じ条件付き書式かどうかの判定は、

・数式1
・数式2
・演算子
・表示形式
・太字
・文字色
・塗りつぶし


以上で判定しています。
従って、例えば、
A1:A10は、>1という条件でFont.Size = 10
A11:A20は、>1という条件でFont.Size = 11
これは、同じ条件付き書式として判定し統合されてしまいます。

実際に、このような設定を使う事がそうそうあるとは思えませんが、
これを別の条件付き書式として判定したい場合は、
上記VBAコードの、
'追加判定したいプロパティはここに追加
これが3箇所ありますので、そこにプロパティを追加してください。

条件付き書式で設定できる書式

セルの書式設定のほとんどを指定できるので多くのプロパティがあります。
VBAでこの違いを全て判定するのは、ちょっとコードを書くのが面倒です。
特に罫線とかは、かなり多くなってしまいます。
実際のところは、
面倒と言うよりサンプルVBAコードとして長くなるだけで意味がないと思いました。

しかし、そもそも、
同じ数式、つまり同じ条件なのに書式のごく一部が違うというような設定を、多用すること自体に問題があるようにも思いますし、
そんな使い方は、そうそうあるものではないだろうと思います。
そして何より、あくまでサンプルVBAだという事で理解してください。

以下は、条件付き書式で設定できるプロパティの一覧になります。
NumberFormatLocal
Font.Bold
Font.Italic
Font.Underline
Font.Strikethrough
Font.Color
Font.TintAndShade
Borders(xlLeft).LineStyle
Borders(xlLeft).TintAndShade
Borders(xlLeft).Weight
Borders(xlRight).LineStyle
Borders(xlRight).TintAndShade
Borders(xlRight).Weight
Borders(xlTop).LineStyle
Borders(xlTop).TintAndShade
Borders(xlTop).Weight
Borders(xlBottom).LineStyle
Borders(xlBottom).TintAndShade
Borders(xlBottom).Weight
Interior.Pattern
Interior.PatternThemeColor
Interior.Color
Interior.TintAndShade
Interior.PatternTintAndShade
StopIfTrue
つまり、すべてのプロパティの違いを判定したいのなら、
先のVBAコードの、
'追加判定したいプロパティはこの上に追加
この部分に、既に入れてある、
NumberFormatLocal
Font.Bold
FontColor
InteriorColor
これ以外を全て追加すれば良いという事です。

ですが、正確にはこれで全てと言う訳ではありません。
塗りつぶし効果でグラデーションを付けている場合に、
その違いまで判定するなら、さらに多くのプロパティの判定が必要になります。

先にも述べましたが、同じ条件でグラデーションだけを変えるなどという使い方が実際にあるとは思えませんが、
もし使っているというのなら、基本的にシートの作成を考え直した方が良いと思います。

増殖した条件付き書式を整理統合するVBAの使い方

上記VBAコード先頭の、
「UnionFormatConditions」がメインのプロシージャーです。

オプションのNewNameが設定されていれば、
元シートをコピーしてから条件付き書式を整理統合します。

VBAコードの詳細解説は省きますが、VBAコード内のコメントを参考に読み解いてみてください。
以下で使い方を説明します。

アクティブシートの条件付き書式を整理統合

Sub sample1()
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  
  Dim ws As Worksheet
  Set ws = ActiveSheet
  Call UnionFormatConditions(ws, ws.Name & "_test")
  
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub

アクティブシートなので、念のためシートをコピーするオプションを指定しています。
整理統合されているかの確認をしやすいので、テスト用とも言えます。

ブック全てのシートの条件付き書式を整理統合する

Sub sample2()
  Dim FileName As Variant
  Dim wb As Workbook
  Dim ws As Worksheet
  
  FileName = Application.GetOpenFilename(FileFilter:="Excelファイル, *.xls*")
  If FileName = False Then
    Exit Sub
  End If
  
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  
  Set wb = Workbooks.Open(FileName:=FileName, UpdateLinks:=0, ReadOnly:=True)
  
  For Each ws In wb.Worksheets
    Call UnionFormatConditions(ws)
  Next
  
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  
  FileName = Application.GetSaveAsFilename(InitialFileName:=wb.Name, _
                       FileFilter:="Excelファイル,*.xls*")
  If FileName = False Then
    Exit Sub
  End If
  wb.SaveAs FileName
  wb.Close SaveChanges:=True
End Sub

ダイアログで対象のファイルを選択し、
保存時にもダイアログでファイルを指定できるようにしています。
全シートが変更になるので、別ブックで保存し確認できるようにしています。

増殖した条件付き書式を整理統合の最後

こうやって、VBAコードを書いてみると、
Excelそのものも修正出来ないこともないように思われました。
「条件付き書式の最適化」
このようなボタンを配置して、条件付き書式を整理統合出来れば良いと思う。

・「もとに戻す」は難しいかもしれません。
・不具合も出るかもしれません。

かなり勝手な言い分としては、
実行時に注意のメッセージを出せば良いことではないかと思うのです。
特殊な使い方をしている場合を考慮して先に進まないよりは、大多数の人の利益を優先すべきではないでしょうか。
それこそ最後には、「それは仕様です」、と言い切ってしまえば良い話だと私は思います。

まだ作成して自分で確認しただけのVBAなので、バグが無いとは言えません。
といいますか、このくらいのVBAになると、バグというか想定外は存在するのが普通です。
上記のVBAコードを使用して、Excelファイルが壊れてしまった等の苦情は受け付けませんが、
バグ報告は大歓迎です。
もしくは、
「もっと簡単にできるよ」、なんて情報は大大歓迎です。



同じテーマ「マクロVBAサンプル集」の記事

印刷ダイアログを使用する(xlDialogPrint)
名前定義の一覧と削除(Name)
シートを名前順に並べ替える
数式内の不要なシート名を削除する(HasFormula)
数式の参照しているセルを取得する
増殖した条件付き書式を整理統合する
条件付き書式で変更された書式を取得する
セル結合/解除でセル値を退避/回復
セル結合なんて絶対に許さないんだからね
セルの数式をネスト色分けしてコメント表示
セル結合して表を見やすくする(非推奨)


新着記事NEW ・・・新着記事一覧を見る

VBA100本ノック 18本目:名前定義の削除|VBA練習問題100(11月6日)
VBA100本ノック 17本目:重複削除(ユニーク化)|VBA練習問題100(11月6日)
VBA100本ノック 16本目:無駄な改行を削除|VBA練習問題100(11月5日)
VBA100本ノック 15本目:シートの並べ替え|VBA練習問題100(11月4日)
VBA100本ノック 14本目:社外秘シート削除|VBA練習問題100(11月3日)
VBA100本ノック 13本目:文字列の部分フォント|VBA練習問題100(11月1日)
VBA100本ノック 12本目:セル結合を解除|VBA練習問題100(10月31日)
VBA100本ノック 11本目:セル結合の警告|VBA練習問題100(10月30日)
VBA100本ノック 10本目:行の削除|VBA練習問題100(10月29日)
VBA100本ノック 9本目:フィルターコピー|VBA練習問題100(10月28日)


アクセスランキング ・・・ ランキング一覧を見る

1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.変数宣言のDimとデータ型|VBA入門
4.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
5.マクロって何?VBAって何?|VBA入門
6.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
7.繰り返し処理(For Next)|VBA入門
8.セルに文字を入れるとは(Range,Value)|VBA入門
9.とにかく書いてみよう(Sub,End Sub)|VBA入門
10.マクロはどこに書くの(VBEの起動)|VBA入門




このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。


記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。



このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
本文下部へ