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

ExcelマクロVBAの実用サンプル、エクセルVBA集と解説
公開日：2018-02-12　最終更新日：2021-04-10

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


コピペによって条件付き書式は際限なく増加していきます。
あまり増えすぎると、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）
・FormatConditionsコレクション ・FormatConditionオブジェクト ・条件付き書式のマクロVBA実践例 ・マクロVBAの条件付き書式について
こちらを参考にしてください。

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 Range '適用範囲
　　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 Object
　　On Error Resume Next '.Formula2が取得できない場合の対処

　　ReDim fAry(ws.Cells.FormatConditions.Count)
　　For i = 1 To ws.Cells.FormatConditions.Count
　　　　If TypeName(ws.Cells.FormatConditions(i)) = "FormatCondition" Then
　　　　　　Set fObj = ws.Cells.FormatConditions(i)
　　　　　　Set fAry(i).AppliesTo = fObj.AppliesTo
　　　　　　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
　　　　　　　　 Set fAry(i).AppliesTo = Nothing
　　　　　　End If
　　　　Else
　　　　　　'以下もありますが､今回は扱いません
　　　　　　'IconSetCondition,ColorScale,Databar,Top10
　　　　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
　　　　　　　　Set fAry(i2).AppliesTo = Union(fAry(i2).AppliesTo, fAry(i1).AppliesTo)
　　　　　　　　Set fAry(i1).AppliesTo = Nothing
　　　　　　　　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 Is Nothing Or _
　　　 fAry2.AppliesTo Is Nothing 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 Range)
　　If sFormula = "" Then Exit Function
　　Dim rng As Range
　　ToR1C1 = Application.ConvertFormula(sFormula, xlA1, xlR1C1, , sAppliesTo.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 Is Nothing Then
　　　　　　fObj.Delete
　　　　Else
　　　　　　If fObj.AppliesTo.Address <> fAry(i).AppliesTo.Address Then
　　　　　　　　fObj.ModifyAppliesToRange 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サンプル集」の記事

シートを名前順に並べ替える
数式内の不要なシート名を削除する（HasFormula）
数式の参照しているセルを取得する
増殖した条件付き書式を整理統合する
条件付き書式で変更された書式を取得する
セル結合/解除でセル値を退避/回復
セル結合なんて絶対に許さないんだからね
セルの数式をネスト色分けしてコメント表示
セル結合して表を見やすくする（非推奨）
シートを削除：不定数のシート名に対応
セル番地でバラバラに指定されたセルの削除


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

TRIMRANGE関数（セル範囲をトリム：端の空白セルを除外）｜エクセル入門(2024-08-30)
正規表現関数（REGEXTEST,REGEXREPLACE,REGEXEXTRACT）｜エクセル入門(2024-07-02)
エクセルが起動しない、Excelが立ち上がらない｜エクセル雑感(2024-04-11)
ブール型（Boolean）のis変数・フラグについて｜VBA技術解説(2024-04-05)
テキストの内容によって図形を削除する｜VBA技術解説(2024-04-02)
ExcelマクロVBA入門目次｜エクセルの神髄(2024-03-20)
VBA10大躓きポイント（初心者が躓きやすいポイント）｜VBA技術解説(2024-03-05)
テンキーのスクリーンキーボード作成｜ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。｜エクセル雑感(2024-02-17)
初級脱出10問パック｜VBA練習問題(2024-01-24)


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

1.最終行の取得（End,Rows.Count）｜VBA入門
2.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
3.繰り返し処理（For Next)｜VBA入門
4.変数宣言のDimとデータ型｜VBA入門
5.RangeとCellsの使い方｜VBA入門
6.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
7.メッセージボックス(MsgBox関数)｜VBA入門
8.セルのクリア（Clear,ClearContents）｜VBA入門
9.ブック・シートの選択（Select,Activate）｜VBA入門
10.条件分岐（Select Case）｜VBA入門



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


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

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
本文下部へ
同じテーマの記事
新着記事
アクセスランク


↑