Excelの条件付き書式を統合整理するマクロ

 みさなん、こんちには! 知識と情報は共有し、広めることで価値を増すと考えている千月です。

 エクセルの条件付き書式、便利ですよね。でも便利な反面、コピペやセルの挿入で無尽蔵に増えていき、無駄にファイルサイズが大きくなってしまったり、エクセルの動作が重くなったり、厄介な機能でもあります。

 この度、条件付き書式を整理・統合するマクロを作りましたので、サイトに載せます!

 マクロの入ったエクセルのアドインファイルを載せるので、アドインファイルとして使用するなり、プロシージャをパーソナルファイルに移動するなり、自分で改良するなりしてご活用ください!

 ファイルはこちら→『ConditionalFormat.xlam』

 エクセルのアドインの導入方法についてはExcel でアドインを追加または削除する(Microsoft Support 別窓)をご参照ください。

・使い方

 『条件付き書式統合整理』という名前のモジュールがメインのマクロです。

  1. 条件付き書式を整理・統合したい範囲を選択します。シート全体を整理・統合したい場合は、1セルだけ選択した状態にしてください。
  2. マクロを開始します。
  3. ファイルを上書き保存するか確認されます。マクロの途中でエクセルが落ちる場合がありますので、後悔のないようにしてください。
  4. マクロが条件付き書式を整理・統合します。

 1行目が奇数だったら、2行目の背景色を赤にする条件付き書式です。

 コピペすると増えます。

 マクロを実行すると、こうなります。

・統合整理される条件付き書式の条件

  1. 条件式を相対参照に変換して、同じ式であること
  2. 設定されている文字色が同じこと
  3. 設定されている背景色が同じこと

 絶対参照を相対参照に変えて、条件式の判定をしております。そのため、絶対参照では違う条件式でも、「同一条件式」と判断されて整理・統合されてしまう場合がありますので、ご注意ください。

・ソース

Sub 条件付き書式統合整理()
  '処理開始前の確認
  Dim Answer As Long
  Answer = MsgBox("条件付き書式を整理します。" & vbNewLine & _
    "連続で条件付き書式を変更するため、エクセルが落ちる場合があります。" & _
    "ファイルを上書き保存しますか?", vbYesNo)
  Select Case Answer
    Case vbYes
      ActiveWorkbook.Save
    Case vbNo
      Answer = MsgBox("ファイルを保存せずに条件付き書式を整理します。", vbYesNo)
      If Answer = vbNo Then End
  End Select
  
  '処理開始
  Call StartProcess
  '条件付き書式の範囲選択
  Dim FCS As FormatConditions
  If Selection.Count = 1 Or Not TypeName(Selection) = "Range" Then
    Set FCS = activeSheet.Cells.FormatConditions
  Else
    Set FCS = Selection.FormatConditions
  End If
  
  '条件付き書式
  Dim FC(1 To 2) As FormatCondition
  '式を確認
  Dim Formula(1 To 4) As String, Ranges(1 To 2) As Range
  '削除判定
  Dim IsDeleted As Boolean, AppTo As String
  
Retry:
  IsDeleted = False
  Dim CntUp As Long, CntDown As Long
  '比較元
  For CntUp = 1 To FCS.Count
    If CntUp > FCS.Count Then Exit For
    Set FC(1) = FCS.Item(CntUp)
    '適応範囲を合体
    FC(1).ModifyAppliesToRange FncUnion(FC(1).AppliesTo.Address)
'    Debug.Print FC(1).AppliesTo.Address
'    Stop

    '式を変換
    Set Ranges(1) = getLeftTopCell(FC(1).AppliesTo) '左上のセルを選択
    '条件式をR1C1形式の相対参照に変換
    Formula(1) = Application.ConvertFormula(FC(1).Formula1, xlA1, xlR1C1, xlRelative, Ranges(1)) 
    '条件式を絶対参照に変換
    Formula(3) = Application.ConvertFormula(FC(1).Formula1, xlA1, xlA1, xlAbsolute) 
    '比較先
    For CntDown = FCS.Count To CntUp Step -1
      Set FC(2) = FCS.Item(CntDown)
      '同一条件を飛ばす
      If FC(1).Priority = FC(2).Priority Then GoTo NextCnt2
      '式変換
      Set Ranges(2) = getLeftTopCell(FC(2).AppliesTo)
      Formula(2) = Application.ConvertFormula(FC(2).Formula1, xlA1, xlR1C1, xlRelative, Ranges(2))
      Formula(4) = Application.ConvertFormula(FC(2).Formula1, xlA1, xlA1, xlAbsolute)
'      Debug.Print CntUp & ":" & CntDown
'      Debug.Print "1:" & Formula(1) & ":  " & "2:" & Formula(2)
'      Debug.Print "1:" & Formula(3) & ":  " & "2:" & Formula(4)
'      Stop

      '条件式が同じか判定
      If Not Formula(1) = Formula(2) Then
        If Not Formula(3) = Formula(4) Then GoTo NextCnt2
      End If
      '書式判定
      If Not FC(1).NumberFormat = FC(2).NumberFormat Then GoTo NextCnt2
      If Not FC(1).Font.Color = FC(2).Font.Color Then GoTo NextCnt2
      If Not FC(1).Interior.Color = FC(2).Interior.Color Then GoTo NextCnt2
      
'      Debug.Print CntUp & ":" & CntDown
'      Debug.Print "1:" & Formula(1) & ":" & "2:" & Formula(2)
'      Debug.Print "1:" & Formula(3) & ":" & "2:" & Formula(4)
      '全て一致なら適用範囲を合体
      FC(1).ModifyAppliesToRange Union(FC(1).AppliesTo, FC(2).AppliesTo)
      '削除
      FC(2).Delete
      IsDeleted = True
      'アイテム削除で変数が不安定になるようなので入れ直す
      Set FC(1) = FCS.Item(CntUp)
NextCnt2:
    Next CntDown
  Next CntUp
  
  '適用範囲で相対参照が変わるため、削除があったらリトライ
  If IsDeleted Then GoTo Retry
  
  MsgBox "条件付き書式の統合整理処理が終了しました。"
  Call EndProcess
End Sub
'左上端のセルを返す
Function getLeftTopCell(ByVal AppTo As Range) As Range
  If AppTo.Areas.Count = 1 Then
    Set getLeftTopCell = AppTo.Cells(1)
    Exit Function
  End If
  
  Dim buf As Range, Min As Range
  Set Min = AppTo.Cells(1)
  
  For Each buf In AppTo.Areas
    If Min.Row > buf.Row Then Set Min = Cells(buf.Row, Min.Column)
    If Min.Column > buf.Column Then Set Min = Cells(Min.Row, buf.Column)
  Next buf
  
  Set getLeftTopCell = Min
End Function
'右下端のセルを返す
Function getRightBottomCell(ByVal AppTo As Range) As Range
  If AppTo.Areas.Count = 1 Then
    Set getRightBottomCell = AppTo.Cells(AppTo.Count)
    Exit Function
  End If
  
  Dim buf As Range, Max As Range
  Set Max = AppTo.Cells(1)
  
  For Each buf In AppTo.Areas
    If Max.Row < buf.Cells(buf.Count).Row Then Set Max = buf.Cells(buf.Count)
    If Max.Column < buf.Cells(buf.Count).Column Then Set Max = buf.Cells(buf.Count)
  Next buf
  
  Set getRightBottomCell = Max
End Function
'セル範囲を結合し最適化
Function FncUnion(ByVal CellAddress As String) As Range
  Set FncUnion = Range(CellAddress)
  'エリア数を確認
  If FncUnion.Areas.Count = 1 Then Exit Function
  
  '二つのエリアの先頭と末尾で比較
  Dim TopCell As Range, BottomCell As Range
  Dim ConpareRange As Range
  
  Dim Cnt As Long, Cnt2 As Long
  For Cnt = 1 To FncUnion.Areas.Count
    '途中でエリア統合して、総数が減るため、再度チェック
    If Cnt > FncUnion.Areas.Count Then Exit For
    
    For Cnt2 = 1 To FncUnion.Areas.Count
      '途中でエリア統合して、総数が減るため、再度チェック
      If Cnt2 > FncUnion.Areas.Count Then Exit For
      If Cnt = Cnt2 Then GoTo NextCnt2
      
      Set ConpareRange = Union(FncUnion.Areas.Item(Cnt), FncUnion.Areas.Item(Cnt2))
      '先頭
      Set TopCell = getLeftTopCell(ConpareRange)
      '末尾
      Set BottomCell = getRightBottomCell(ConpareRange)
      
      '元のセル数とRange(先頭,末尾)のセル数を比較
      If getCellsCount(ConpareRange) = getCellsCount(Range(TopCell, BottomCell)) Then
        Set FncUnion = Union(FncUnion, Range(TopCell, BottomCell))
      End If
      
NextCnt2:
    Next Cnt2
  Next Cnt
  
End Function
'結合セルに対応
Function getCellsCount(ByVal TargetRange As Range) As Long
  '結合セル範囲をunionしていって最後に数える
  Dim buf As Range
  Set buf = TargetRange.Cells(1).MergeArea
  
  Dim Cnt As Long
  For Cnt = 2 To TargetRange.Count
    Set buf = Union(buf, TargetRange.Cells(Cnt).MergeArea)
  Next Cnt
  
  getCellsCount = buf.Count
End Function

 ソースは以上です。

 結構、細かくコメントを書いているので、『1ステップ実行+解らないプロパティ・メソッドは、選択してF1キーでヘルプファイルを読む』ことでやっていることは理解できるかと思います。

 デバッグ用のコードもコメント化して残しているので、アンコメトしてイミディエイト・ウィンドウを確認しつつ実行してみると、より解りやすいかと思います。

 なんか色々と面倒くさそうだな、と思った方はアドインを導入して、とにかく実行してみてください!

 このマクロで、あなたの作業時のストレスが減少すること・作業効率が上がることを祈っています!

更新日:

戻る inserted by FC2 system