エクセルの条件付き書式、便利ですよね。でも便利な反面、コピペやセルの挿入で無尽蔵に増えていき、無駄にファイルサイズが大きくなってしまったり、エクセルの動作が重くなったり、厄介な機能でもあります。
マクロの入ったエクセルのアドインファイルを載せるので、アドインファイルとして使用するなり、プロシージャをパーソナルファイルに移動するなり、自分で改良するなりしてご活用ください!
・ソース
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)
Set Ranges(1) = getLeftTopCell(FC(1).AppliesTo)
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)
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
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)
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
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キーでヘルプファイルを読む』ことでやっていることは理解できるかと思います。
デバッグ用のコードもコメント化して残しているので、アンコメトしてイミディエイト・ウィンドウを確認しつつ実行してみると、より解りやすいかと思います。
なんか色々と面倒くさそうだな、と思った方はアドインを導入して、とにかく実行してみてください!
このマクロで、あなたの作業時のストレスが減少すること・作業効率が上がることを祈っています!