増殖した条件付き書式を整理統合（旧VBA）
コピペによって条件付き書式は際限なく増加していきます。
あまり増えすぎるとExcelの動作が遅くなる場合もありますし、条件や書式を変更したい時にも困ることになります。
増殖した条件付き書式を整理統合する
・条件付き書式の増殖に関する、Microsoft サポート ・増殖した条件付き書式の実例と対応 ・簡単なVBAでの対応 ・VBAで条件付き書式を整理統合した結果 ・今回のVBAコードの発想について ・Application.ConvertFormulaメソッド ・増殖した条件付き書式を整理統合するVBA ・条件付き書式で設定できる書式 ・増殖した条件付き書式を整理統合するVBAの使い方 ・増殖した条件付き書式を整理統合の最後
今回のVBAコードの発想について
この仕様については、私も結構悩まされてきました。
手作業で、幾度となく条件付き書式を再設定してきました。
頻繁に発生するシートの場合は、
先に示したようなVBAで、
条件付き書式を削除して再設定できるようにマクロを用意しておいたりして対処してきました。
常々、この仕様は困ったものだとの思いと、なんとか出来ないものかとの思いは持っていました。
最近も条件付き書式が増加しているシートがあったので、手作業で再設定していて、
「これ、なんとか出来ないかなー、出来ないことないはずだよなー」、と思い立ち、
いろいろ考えてみたのですが、これがかなり難しい。
・何をもって、増殖してしまった条件付き書式と判定するのか
・何をもって、同じ条件付き書式と判定するのか
VBAコードのプログラミング以前に、仕様を決定出来ないのです。
頭を整理して、良く考えてみました。
一番の問題は、
・数式が同じかどうかの判定
適用先：=$A$1:$A$10
適用先：=$A$11:$A$20
この2つの条件付き書式は同じものです。
コピペで作ったものです。
セル範囲の条件付き書式では、多くの数式は相対参照で書かれています。
つまり、コピーで増えた条件付き書式の数式は、コピペ先のセル参照に変更されています。
条件付き書式が設定されているセルと、数式が参照しているセルの位置関係が同じかどうか、
そんな判定をどうやってしたら良いのか・・・
参照しているセルの数に制限はない・・・
文字列操作でセル参照を取り出し相対位置を変更・・・
とても現実的とは思えない・・・
いろいろと考えを巡らしているとき、
～VBAの神様が下りてきた～
同じセルにコピペして、その数式が同じなら同じ数式ではないか！
それならば、
それぞれの条件付き書式が設定されている先頭セルに、条件付き書式の数式を入れて、
そのセルをコピペで特定のセルに入れた結果の数式で判定できそうです。
この発想で道が開けました。
後は、VBAコードを書くだけ、やることが決まればVBAを書くのは大した問題ではありません。
実際のVBAコードを書く所要時間としては、
分断されているセル範囲が連続セル範囲なのかの判定や、
複数のセル範囲を1つのセル範囲として再定義する部分のコード作成に時間がかかりました。
手作業で、幾度となく条件付き書式を再設定してきました。
頻繁に発生するシートの場合は、
先に示したようなVBAで、
条件付き書式を削除して再設定できるようにマクロを用意しておいたりして対処してきました。
「これ、なんとか出来ないかなー、出来ないことないはずだよなー」、と思い立ち、
いろいろ考えてみたのですが、これがかなり難しい。
・何をもって、同じ条件付き書式と判定するのか
頭を整理して、良く考えてみました。
一番の問題は、
コピペで作ったものです。
つまり、コピーで増えた条件付き書式の数式は、コピペ先のセル参照に変更されています。
そんな判定をどうやってしたら良いのか・・・
参照しているセルの数に制限はない・・・
文字列操作でセル参照を取り出し相対位置を変更・・・
とても現実的とは思えない・・・
それぞれの条件付き書式が設定されている先頭セルに、条件付き書式の数式を入れて、
そのセルをコピペで特定のセルに入れた結果の数式で判定できそうです。
後は、VBAコードを書くだけ、やることが決まればVBAを書くのは大した問題ではありません。
分断されているセル範囲が連続セル範囲なのかの判定や、
複数のセル範囲を1つのセル範囲として再定義する部分のコード作成に時間がかかりました。
以下が、完成したVBAコードになります。
Option Explicit
Type tFormat
AppliesTo As String '適用範囲
Formula1 As String '数式1
Formula2 As String '数式2
NumberFormatLocal As String '表示形式
FontBold As String '太字
FontColor As String '文字色
InteriorColor As String '塗りつぶし色
'追加判定したいプロパティはこの上に追加
StartRange As String '範囲先頭
FormulaLocal1 As String 'Formula1の数式判定用
FormulaLocal2 As String 'Formula2の数式判定用
End Type
Public Sub UnionFormatConditions(ByVal ws As Worksheet, Optional ByVal NewName As String = "")
Dim i As Long
Dim ii As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim fObj As Object
Dim fAry() As tFormat
Dim sRange As String
Dim flg As Boolean
'条件付き書式が無い場合は終了
If ws.Cells.FormatConditions.Count = 0 Then
Exit Sub
End If
'オプションにより元シートをコピー
If NewName = "" Then
Set ws1 = ws
Else
ws.Copy After:=ws
Set ws1 = ActiveSheet
ws1.Name = NewName
End If
'条件付き書式を構造体配列へ格納
On Error Resume Next '.Formula2が取得できない場合の対処
For i = 1 To ws1.Cells.FormatConditions.Count
ReDim Preserve fAry(i)
Set fObj = ws1.Cells.FormatConditions(i)
If TypeName(fObj) = "FormatCondition" Then
Set fObj = ws1.Cells.FormatConditions(i)
fAry(i).AppliesTo = fObj.AppliesTo.Address
fAry(i).Formula1 = fObj.Formula1
fAry(i).Formula2 = fObj.Formula2
fAry(i).NumberFormatLocal = fObj.NumberFormatLocal
fAry(i).FontBold = fObj.Font.Bold
fAry(i).FontColor = fObj.Font.Color
fAry(i).InteriorColor = fObj.Interior.Color
'追加判定したいプロパティはこの上に追加
End If
Next
On Error GoTo 0
'編集用シート挿入
Set ws2 = Worksheets.Add
'同一条件付き書式の判定
For i = 1 To UBound(fAry)
If fAry(i).AppliesTo <> "" Then
'先頭セルの取得
sRange = getStartAddress(fAry(i).AppliesTo)
fAry(i).StartRange = sRange
'念の為、演算の計算式をセルに入れて再取得
ws2.Range(sRange) = fAry(i).Formula1
fAry(i).FormulaLocal1 = ws2.Range(sRange).FormulaLocal
If fAry(i).Formula2 <> "" Then
ws2.Range(sRange) = fAry(i).Formula2
fAry(i).FormulaLocal2 = ws2.Range(sRange).FormulaLocal
End If
'計算式1,2、文字色、塗りつぶしの一致判定
For ii = 1 To i - 1
If fAry(ii).AppliesTo <> "" Then
flg = True
'計算式1
ws2.Range(sRange) = fAry(i).Formula1
ws2.Range(sRange).Copy Destination:=ws2.Range(fAry(ii).StartRange)
If ws2.Range(fAry(ii).StartRange).FormulaLocal <> fAry(ii).FormulaLocal1 Then
flg = False
End If
'計算式2
If fAry(i).Formula2 <> "" Then
ws2.Range(sRange) = fAry(i).Formula2
ws2.Range(sRange).Copy Destination:=ws2.Range(fAry(ii).StartRange)
If ws2.Range(fAry(ii).StartRange).FormulaLocal <> fAry(ii).FormulaLocal2 Then
flg = False
End If
End If
'表示形式
If fAry(i).NumberFormatLocal <> fAry(ii).NumberFormatLocal Then flg = False
'太字
If fAry(i).FontBold <> fAry(ii).FontBold Then flg = False
'文字色
If fAry(i).FontColor <> fAry(ii).FontColor Then flg = False
'塗りつぶし
If fAry(i).InteriorColor <> fAry(ii).InteriorColor Then flg = False
'追加判定したいプロパティはこの上に追加
'全てがが一致していれば統合
If flg = True Then
fAry(ii).AppliesTo = fAry(ii).AppliesTo & "," & fAry(i).AppliesTo
fAry(i).AppliesTo = ""
Exit For
End If
End If
Next
End If
Next
'複数セル範囲を統合、デバッグしやすいようにここで
For i = 1 To UBound(fAry)
If fAry(i).AppliesTo <> "" Then
fAry(i).AppliesTo = getUnionAddress(fAry(i).AppliesTo)
End If
Next
'条件付き書式の統合
For i = ws1.Cells.FormatConditions.Count To 1 Step -1
Set fObj = ws1.Cells.FormatConditions(i)
If TypeName(fObj) = "FormatCondition" Then
If fAry(i).AppliesTo = "" Then
fObj.Delete
Else
If fObj.AppliesTo.Address <> ws1.Range(fAry(i).AppliesTo).Address Then
fObj.ModifyAppliesToRange ws1.Range(fAry(i).AppliesTo)
End If
End If
End If
Next
'編集用シート削除
Application.DisplayAlerts = False
ws2.Delete
Application.DisplayAlerts = True
End Sub
'複数のセル範囲指定から先頭セルを取得
Private Function getStartAddress(ByVal sAddress As String) As String
Dim i As Long
Dim iRow As Long
Dim iCol As Long
Dim sSplit() As String
Dim myRange As Range
iRow = 9999999
iCol = 9999999
sSplit = Split(sAddress, ",")
For i = 0 To UBound(sSplit)
Set myRange = Range(sSplit(i))
If myRange.Row < iRow Or _
myRange.Column < iCol Then
iRow = myRange.Row
iCol = myRange.Column
End If
Next
getStartAddress = Cells(iRow, iCol).Address
End Function
'複数のセル範囲指定から最終セルを取得
Private Function getEndAddress(ByVal sAddress As String) As String
Dim i As Long
Dim iRow As Long
Dim iCol As Long
Dim sSplit() As String
Dim myRange As Range
iRow = 0
iCol = 0
sSplit = Split(sAddress, ",")
For i = 0 To UBound(sSplit)
Set myRange = Range(sSplit(i))
Set myRange = myRange.Item(myRange.Count)
If myRange.Row > iRow Or _
myRange.Column > iCol Then
iRow = myRange.Row
iCol = myRange.Column
End If
Next
getEndAddress = Cells(iRow, iCol).Address
End Function
'2つの範囲が結合されなくなるまで繰り返す
Private Function getUnionAddress(ByVal sAddress As String) As String
Dim sTemp1 As String
Dim sTemp2 As String
sTemp1 = sAddress
Do
sTemp2 = getUnionAddress1(sTemp1)
If sTemp1 = sTemp2 Then
getUnionAddress = sTemp2
Exit Function
End If
sTemp1 = sTemp2
Loop
End Function
'2つの範囲を取り出して結合
Private Function getUnionAddress1(ByVal sAddress As String) As String
Dim i1 As Long
Dim i2 As Long
Dim sSplit() As String
Dim sTemp1 As String
Dim sTemp2 As String
sSplit = Split(sAddress, ",")
For i1 = 0 To UBound(sSplit)
For i2 = i1 + 1 To UBound(sSplit)
sTemp1 = sSplit(i1) & "," & sSplit(i2)
sTemp2 = getUnionAddress2(sTemp1)
If sTemp1 <> sTemp2 Then
sSplit(i1) = sTemp2
sSplit(i2) = ""
getUnionAddress1 = JoinCamma(sSplit)
Exit Function
End If
Next
Next
getUnionAddress1 = sAddress
End Function
'セル範囲を結合し最適化
Private Function getUnionAddress2(ByVal sAddress As String) As String
Dim i1 As Long
Dim i2 As Long
Dim sStart As String
Dim sEnd As String
Dim sSplit() As String
Dim myRange As Range
'2つのセルが完全に片方を内包している場合の統合
sSplit = Split(sAddress, ",")
For i1 = 0 To UBound(sSplit)
For i2 = i1 + 1 To UBound(sSplit)
Set myRange = Intersect(Range(sSplit(i1)), Range(sSplit(i2)))
If Not myRange Is Nothing Then
If myRange.Address = Range(sSplit(i1)).Address Then
sSplit(i1) = ""
ElseIf myRange.Address = Range(sSplit(i2)).Address Then
sSplit(i2) = ""
End If
End If
Next
Next
sAddress = JoinCamma(sSplit)
'範囲の先頭と最後の範囲のセル数と、元のセル数が同じなら結合
sStart = getStartAddress(sAddress)
sEnd = getEndAddress(sAddress)
If Range(sStart, sEnd).Count = Range(sAddress).Count Then
getUnionAddress2 = Range(sStart, sEnd).Address
Else
getUnionAddress2 = sAddress
End If
End Function
'配列をJOINし不要カンマを削除
Private Function JoinCamma(ByRef sSplit() As String) As String
JoinCamma = Join(sSplit, ",")
JoinCamma = Replace(JoinCamma, ",,", ",")
If Left(JoinCamma, 1) = "," Then
JoinCamma = Mid(JoinCamma, 2)
End If
If Right(JoinCamma, 1) = "," Then
JoinCamma = Left(JoinCamma, Len(JoinCamma) - 1)
End If
End Function
下半分くらいは、
セル範囲指定のアドレスをまとめるためのVBAコードになっています。
↓
=$A$1:$A$30
ここは頑張って、VBAコードをただひたすら書き足していきました。
・数式2
・表示形式
・太字
・文字色
・塗りつぶし
A1:A10は、>1という条件でFont.Size = 10
A11:A20は、>1という条件でFont.Size = 11
これは、同じ条件付き書式として判定し統合されてしまいます。
これを別の条件付き書式として判定したい場合は、
上記VBAコードの、
'追加判定したいプロパティはこの上に追加
これが3箇所ありますので、そこにプロパティを追加してください。
同じテーマ「マクロVBAサンプル集」の記事
シートを名前順に並べ替える
数式内の不要なシート名を削除する（HasFormula）
数式の参照しているセルを取得する
増殖した条件付き書式を整理統合する
条件付き書式で変更された書式を取得する
セル結合/解除でセル値を退避/回復
セル結合なんて絶対に許さないんだからね
セルの数式をネスト色分けしてコメント表示
セル結合して表を見やすくする（非推奨）
シートを削除：不定数のシート名に対応
セル番地でバラバラに指定されたセルの削除
新着記事NEW ・・・新着記事一覧を見る
ブール型（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)
累計を求める数式あれこれ｜エクセル関数応用(2024-01-22)
複数の文字列を検索して置換するSUBSTITUTE｜エクセル入門(2024-01-03)
いくつかの数式の計算中にリソース不足になりました。｜エクセル雑感(2023-12-28)
アクセスランキング ・・・ ランキング一覧を見る
1.最終行の取得（End,Rows.Count）｜VBA入門
2.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
3.RangeとCellsの使い方｜VBA入門
4.ひらがな⇔カタカナの変換｜エクセル基本操作
5.繰り返し処理（For Next)｜VBA入門
6.変数宣言のDimとデータ型｜VBA入門
7.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
8.並べ替え（Sort）｜VBA入門
9.セルのクリア（Clear,ClearContents）｜VBA入門
10.Findメソッド（Find,FindNext,FindPrevious）｜VBA入門
- ホーム
- マクロVBA応用編
- マクロVBAサンプル集
- 増殖した条件付き書式を整理統合（旧VBA）
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。