はじめに
あるセルに条件付き書式数式を入力し、そのセルをコピーした場合、隣あうセルであっても条件付き書式が増殖します。
この時に、増殖した条件付き書式が同じものであれば統合します。
以下の図は条件付き書式を設定したA1セルをA2セルにコピーした後の状態です。
このマクロを実行した後はこうなります。
ソースコード
GitHubからダウンロード出来ます。
Private Type TSaveInfo
NewAppliesTo As Range '再設定させるセル範囲
Delete As Boolean 'True:削除対象
End Type
'*****************************************************************************
'[概要] アクティブシートの条件付き書式を統合する
'[引数] なし
'[戻値] なし
'*****************************************************************************
Public Sub MergeFormatConditions()
Call MergeSameFormatConditions(ActiveSheet)
End Sub
'*****************************************************************************
'[概要] ワークシート内の条件付き書式を統合する
'[引数] 対象のワークシート
'[戻値] なし
'*****************************************************************************
Private Sub MergeSameFormatConditions(ByRef objWorksheet As Worksheet)
Dim FConditions As FormatConditions
Set FConditions = objWorksheet.Cells.FormatConditions
If FConditions.Count = 0 Then
Exit Sub
End If
ReDim SaveArray(1 To FConditions.Count) As TSaveInfo
Dim i As Long
Dim j As Long
'条件付き書式を後方からLOOPし、統合出来るかどうかの情報をSaveArrayに設定
For i = FConditions.Count To 1 Step -1
For j = 1 To i - 1
If IsSameFormatCondition(FConditions(i), FConditions(j)) Then
'(i)と(j)が等しければ、後方の(i)を削除して、前方の(j)に統合
If SaveArray(j).NewAppliesTo Is Nothing Then
Set SaveArray(j).NewAppliesTo = Application.Union(FConditions(i).AppliesTo, FConditions(j).AppliesTo)
Else
Set SaveArray(j).NewAppliesTo = Application.Union(FConditions(i).AppliesTo, SaveArray(j).NewAppliesTo)
End If
SaveArray(i).Delete = True
End If
Next
Next
'条件付き書式を後方から削除し、前方の条件付き書式に統合
For i = FConditions.Count To 1 Step -1
If SaveArray(i).Delete = True Then
Call FConditions(i).Delete
Else
If Not (SaveArray(i).NewAppliesTo Is Nothing) Then
'条件付き書式の統合
Call FConditions(i).ModifyAppliesToRange(SaveArray(i).NewAppliesTo)
End If
End If
Next
'A1,A2,A3 → A1:A3 のように領域を整理
Dim objWk As Range
'FormatConditionsを圧縮したため再設定
Set FConditions = objWorksheet.Cells.FormatConditions
For i = FConditions.Count To 1 Step -1
With FConditions(i)
If .AppliesTo.Areas.Count > 1 Then
Set objWk = .AppliesTo
'A1,A2,A3 → A1:A3 のように領域を整理
Set objWk = Application.Intersect(objWk, objWk)
'領域が左上から並ぶようにソートする 例:E:F,B:B → B:B,E:F
Set objWk = SortAreas(objWk)
Call .ModifyAppliesToRange(objWk)
End If
End With
Next
End Sub
'*****************************************************************************
'[概要] 条件および書式が一致するか判定
'[引数] 比較対象のFormatConditionオブジェクト
'[戻値] True:一致
'*****************************************************************************
Private Function IsSameFormatCondition(ByRef F1 As Object, ByRef F2 As Object) As Boolean
IsSameFormatCondition = False
If Not (TypeOf F1 Is FormatCondition) Then
Exit Function
End If
If Not (TypeOf F2 Is FormatCondition) Then
Exit Function
End If
' Select Case F1.Type
' 'セルの値、数式、文字列、期間 のみ判定対象とする → FormatConditionはすべて対象にする
' Case xlCellValue, xlExpression, xlTextString, xlTimePeriod
' Case Else
' Exit Function
' End Select
If IsSameCondition(F1, F2) Then
IsSameFormatCondition = IsSameFormat(F1, F2)
End If
End Function
'*****************************************************************************
'[概要] 条件が一致するか判定
'[引数] 比較対象のFormatConditionオブジェクト
'[戻値] True:一致
'*****************************************************************************
Private Function IsSameCondition(ByRef F1 As FormatCondition, ByRef F2 As FormatCondition) As Boolean
Dim Operator(1 To 2) As String '次の値に等しい、次の値の間etc
Dim TextOperator(1 To 2) As String 'Type=xlTextStringの時、次の値を含む、次の値で始まるetc
Dim Text(1 To 2) As String 'Type=xlTextStringの時の文字列
Dim Formula1_R1C1(1 To 2) As String '数式をR1C1タイプで設定
Dim Formula2_R1C1(1 To 2) As String '数式をR1C1タイプで設定
'タイプによっては直接判定すると例外となる項目があるため例外を抑制して変数に設定
On Error Resume Next
With F1
Operator(1) = .Operator
TextOperator(1) = .TextOperator
Text(1) = .Text
Formula1_R1C1(1) = Application.ConvertFormula(.Formula1, xlA1, xlR1C1, , GetTopLeftCell(.AppliesTo))
Formula2_R1C1(1) = Application.ConvertFormula(.Formula2, xlA1, xlR1C1, , GetTopLeftCell(.AppliesTo))
End With
With F2
Operator(2) = .Operator
TextOperator(2) = .TextOperator
Text(2) = .Text
Formula1_R1C1(2) = Application.ConvertFormula(.Formula1, xlA1, xlR1C1, , GetTopLeftCell(.AppliesTo))
Formula2_R1C1(2) = Application.ConvertFormula(.Formula2, xlA1, xlR1C1, , GetTopLeftCell(.AppliesTo))
End With
On Error GoTo 0
IsSameCondition = (F1.Type = F2.Type) _
And (Operator(1) = Operator(2)) _
And (TextOperator(1) = TextOperator(2)) _
And (Text(1) = Text(2)) _
And (Formula1_R1C1(1) = Formula1_R1C1(2)) _
And (Formula2_R1C1(1) = Formula2_R1C1(2))
End Function
'*****************************************************************************
'[概要] 書式が一致するか判定
'[引数] 比較対象のFormatConditionオブジェクト
'[戻値] True:一致
'*****************************************************************************
Private Function IsSameFormat(ByRef F1 As FormatCondition, ByRef F2 As FormatCondition) As Boolean
Dim FontBold(1 To 2) As String 'フォント太字
Dim FontColor(1 To 2) As String 'フォント色
Dim InteriorColor(1 To 2) As String '塗りつぶし色
Dim NumberFormat(1 To 2) As String '値の表示形式 例：#,##0
'場合によっては直接判定すると例外となる項目があることを考慮して例外を抑制し変数に設定
On Error Resume Next
With F1
FontBold(1) = .Font.Bold
FontColor(1) = .Font.Color
InteriorColor(1) = .Interior.Color
NumberFormat(1) = .NumberFormat
End With
With F2
FontBold(2) = .Font.Bold
FontColor(2) = .Font.Color
InteriorColor(2) = .Interior.Color
NumberFormat(2) = .NumberFormat
End With
On Error GoTo 0
IsSameFormat = (FontBold(1) = FontBold(2)) _
And (FontColor(1) = FontColor(2)) _
And (InteriorColor(1) = InteriorColor(2)) _
And (NumberFormat(1) = NumberFormat(2))
End Function
'*****************************************************************************
'[概要] 一番左上のセルを取得する
'[引数] 条件付き書式の適用範囲
'[戻値] 一番左上のセル
'*****************************************************************************
Private Function GetTopLeftCell(ByRef objRange As Range) As Range
Dim objArea As Range
Dim lngRow As Long
Dim lngCol As Long
'最大値を初期設定
lngRow = Rows.Count
lngCol = Columns.Count
For Each objArea In objRange.Areas
With objArea.Cells(1) '領域ごとの一番左上のセル
lngRow = WorksheetFunction.Min(lngRow, .Row)
lngCol = WorksheetFunction.Min(lngCol, .Column)
End With
Next
Set GetTopLeftCell = objRange.Worksheet.Cells(lngRow, lngCol)
End Function
'*****************************************************************************
'[概要] 領域が左上から並ぶようにソートする 例:E:F,B:B → B:B,E:F
'[引数] 条件付き書式の適用範囲
'[戻値] ソート後の適用範囲
'*****************************************************************************
Private Function SortAreas(ByRef objRange As Range) As Range
ReDim SortArray(1 To objRange.Areas.Count) As Currency
Dim i As Long
Dim j As Long
'Sort対象の配列を作成
For i = 1 To objRange.Areas.Count
With objRange.Areas(i)
'上5桁は列番号、中7桁は行番号、下4桁はIndex
SortArray(i) = CCur(Format(.Column, "00000") & _
Format(.Row, "0000000") & _
Format(i, "0000"))
End With
Next
'Sort
Dim Swap As Currency
For i = objRange.Areas.Count To 1 Step -1
For j = 1 To i - 1
If SortArray(j) > SortArray(j + 1) Then
Swap = SortArray(j)
SortArray(j) = SortArray(j + 1)
SortArray(j + 1) = Swap
End If
Next j
Next i
'結果設定
j = Right(SortArray(1), 4) 'Index=下4桁
Set SortAreas = objRange.Areas(j)
For i = 2 To UBound(SortArray)
j = Right(SortArray(i), 4) 'Index=下4桁
Set SortAreas = Application.Union(SortAreas, objRange.Areas(j))
Next
End Function
'*****************************************************************************
'[概要] Debug用のセル関数
'[引数] objCell:条件付き書式の設定されたセル、n:FormatConditionsの何番目？
' InfoNo:個別の情報を表示したい時、s(i)のIndexを設定
'[戻値] 例：Type:1 Operator:4 TextOperator:# Text:# Formula1:=0 Formula2:# Formula1:=0 Formula2:# AppliesTo:A1:A20
'*****************************************************************************
Public Function GetFConditionInfo(objCell As Range, ByVal n As Long, Optional ByVal InfoNo As Long = 0) As String
Dim objFCondition As Object
Set objFCondition = objCell.FormatConditions(n)
Dim s(1 To 12)
Dim i As Long
For i = 1 To UBound(s)
s(i) = "#" 'エラーの時
Next
On Error Resume Next
With objFCondition
s(1) = .Type
s(2) = .Priority
s(3) = TypeName(objFCondition)
s(4) = .Operator
s(5) = .TextOperator
s(6) = .Text
s(7) = .Formula1
s(8) = .Formula2
s(9) = Application.ConvertFormula(.Formula1, xlA1, xlR1C1, , GetTopLeftCell(.AppliesTo))
s(10) = Application.ConvertFormula(.Formula2, xlA1, xlR1C1, , GetTopLeftCell(.AppliesTo))
s(11) = .AppliesTo.AddressLocal(False, False)
s(12) = GetTopLeftCell(.AppliesTo).AddressLocal(False, False)
End With
On Error GoTo 0
If InfoNo > 0 Then
GetFConditionInfo = s(InfoNo)
Else
Dim strMsg As String
strMsg = "Type:{1} Priority:{2} TypeName:{3} Operator:{4} TextOperator:{5} Text:{6} Formula1:{7} Formula2:{8} Formula1:{9} Formula2:{10} AppliesTo:{11} TopLeftCell:{12}"
For i = 1 To UBound(s)
strMsg = Replace(strMsg, "{" & i & "}", s(i))
Next
GetFConditionInfo = strMsg
End If
End Function
使い方
条件付き書式を統合したいシートを開きMergeFormatConditions()を実行します。
なお、統合の対象となる条件付き書式は、以下の２種類だけです。
また同一と判定する書式は、
・フォントの太字
・フォントの色
・セルの塗りつぶしの色
・値の表示形式 例：#,##0 など
のみです。
例えば罫線などの設定が相違していても、判定の対象外としているため、もし条件が同じならば統合してしまいます。
判定に追加したい書式があればIsSameFormat()関数の中身を、必要に応じて変更してください。
解説
条件付き書式の情報を保持するFormatConditionオブジェクトの条件と書式が等しいセル範囲は、同一の条件付き書式とみなして結合しています。
この時問題になるのが、条件の数式が等しいことをどのように判定するかですが、その方法は以下の記事を参考にしてください。
同一シート内の同一数式を選択するEXCELマクロ
簡単に説明すれば、R1C1形式の数式が同じであれば同一条件と判定できます。
この時、A1形式をR1C1形式に変換する関数ConvertFormula()には相対参照形式の起点となるセルを引数に設定しますが、各条件付き書式の対象領域の一番左上のセルを設定しています。