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

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

増殖した条件付き書式を整理統合(旧VBA)


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


これを解決するVBAを考えて公開した、初期のマクロVBAをここに残しておきます。

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

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

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

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

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

VBAコードのプログラミング以前に、仕様を決定出来ないのです。
頭を整理して、良く考えてみました。
一番の問題は、

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

適用先:=$A$1:$A$10
VBA マクロ 画像

適用先:=$A$11:$A$20
VBA マクロ 画像

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

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

条件付き書式が設定されているセルと、数式が参照しているセルの位置関係が同じかどうか、
そんな判定をどうやってしたら良いのか・・・
参照しているセルの数に制限はない・・・
文字列操作でセル参照を取り出し相対位置を変更・・・
とても現実的とは思えない・・・

いろいろと考えを巡らしているとき、

~VBAの神様が下りてきた~

同じセルにコピペして、その数式が同じなら同じ数式ではないか!

それならば、
それぞれの条件付き書式が設定されている先頭セルに、条件付き書式の数式を入れて、
そのセルをコピペで特定のセルに入れた結果の数式で判定できそうです。

この発想で道が開けました。
後は、VBAコードを書くだけ、やることが決まればVBAを書くのは大した問題ではありません。

実際のVBAコードを書く所要時間としては、
分断されているセル範囲が連続セル範囲なのかの判定や、
複数のセル範囲を1つのセル範囲として再定義する部分のコード作成に時間がかかりました。


以下が、完成したVBAコードになります。


増殖した条件付き書式を整理統合する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$11:$A$20,$A$1:$A$10,$A$21:$A$30

=$A$1:$A$30

つまり、条件付き書式の統合だけなら、下半分は不要だという事です。

とはいえ、適用範囲がカンマでいくつにも区切られていたのでは見づらいです。
ここは頑張って、VBAコードをただひたすら書き足していきました。

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

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


以上で判定しています。

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

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



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

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


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

import文(パッケージ・モジュールのインポート)|Python入門(9月24日)
例外処理(try文)とexception一覧|Python入門(9月23日)
リスト内包表記|Python入門(9月22日)
Pythonの引数は参照渡しだが・・・|Python入門(9月21日)
lambda(ラムダ式、無名関数)と三項演算子|Python入門(9月20日)
関数内関数(関数のネスト)とスコープ|Python入門(9月18日)
関数の定義(def文)と引数|Python入門(9月18日)
組み込み関数一覧|Python入門(9月17日)
辞書(dict型)|Python入門(9月16日)
入力規則への貼り付けを禁止する|VBA技術解説(9月16日)


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

1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.変数宣言のDimとデータ型|VBA入門
4.マクロって何?VBAって何?|VBA入門
5.セルのコピー&値の貼り付け(PasteSpecial)|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」をお願いいたします。
本文下部へ