https://www.limecode.jp/entry/fungo/049-match-format-condition

Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答と解説のページです。

100本ノックの出題リストはこちらから
excel-ubara.com

出題：条件付き書式の判定

#VBA100本ノック 49本目
D列には以下の条件付き書式が設定されています。
・文字色(赤)
・塗りつぶし(赤,黄)
条件が適用されている行を別シートに値を転記し、同じ文字色と塗りつぶしをセルの書式に設定してください。
※元セルは書式設定されていません。
※転記元と転記先シートは任意

条件付き書式設定データ

◇ 出題ページはこちら

ソースコード

定義モジュール

Option Explicit

' データ
Public Const R1stデータ = 2
Public Const C1stデータ = 1
Public Enum CNoデータ
    科目 = C1stデータ
    項目1
    項目2
    項目3
End Enum
Public Const CLastデータ = CNoデータ.項目3

メインモジュール

Option Explicit

' 100本ノック049：条件付き書式の判定
Sub 条件付き書式の合致データのみを抽出シートに出力する()
    
    Call 指定行より下をすべて削除する(WS抽出, R1stデータ)
    
    ' データ全行をループ
    Dim CLastデータ As Long: CLastデータ = Get最終列(WSデータ)
    Dim R_出力 As Long: R_出力 = R1stデータ
    Dim R As Long
    For R = R1stデータ To Get最終行(WSデータ)
        
        Dim 判定セル As Range
        Set 判定セル = WSデータ.Cells(R, CNoデータ.項目3)
        
        ' 対象の表示書式か判定
        If 判定セル.DisplayFormat.Font.Color = vbRed Or _
           判定セル.DisplayFormat.Interior.Color = vbRed Or _
           判定セル.DisplayFormat.Interior.Color = vbYellow Then
            
            ' データを転記
            Call 値をコピーする(WSデータ.Cells(R, 1) _
                                 , WS抽出.Cells(R_出力, 1), , CLastデータ)
            
            ' 文字色を反映
            If 判定セル.DisplayFormat.Font.Color = vbRed Then
                WS抽出.Cells(R_出力, CNoデータ.項目3).Font.Color _
                                  = 判定セル.DisplayFormat.Font.Color
            End If
            
            ' 背景色を反映
            If 判定セル.DisplayFormat.Interior.Color = vbRed Or _
               判定セル.DisplayFormat.Interior.Color = vbYellow Then
                WS抽出.Cells(R_出力, CNoデータ.項目3).Interior.Color _
                                  = 判定セル.DisplayFormat.Interior.Color
            End If
        
            R_出力 = R_出力 + 1
            
        End If
        
    Next
    
End Sub

汎用関数モジュール

Option Explicit

' 指定行より下の削除
' 参考：https://www.limecode.jp/entry/utility/delete-rows-below-to-last
Sub 指定行より下をすべて削除する(対象シート As Worksheet, 指定行 As Long)
    With 対象シート
    
        Call フィルターをクリアする(対象シート)
        
        .Range(.Rows(指定行), .Rows(.Rows.Count)).Delete
        
    End With
End Sub

' フィルターのクリア
' ◆ ブログ未掲載
Sub フィルターをクリアする(対象シート As Worksheet)
    If 対象シート.AutoFilterMode = True Then
        If 対象シート.AutoFilter.FilterMode = True Then
            対象シート.AutoFilter.ShowAllData
        End If
    End If
End Sub

' 最終行の取得
' 参考：https://www.limecode.jp/entry/library/get-lastrow-lastcolumn
Function Get最終行(指定オブジェクト As Variant, Optional ByVal C As Long = -1) As Long

    ' 渡されたオブジェクトからセル範囲を取得
    Dim 対象セル範囲 As Range
    Select Case TypeName(指定オブジェクト)
    Case "Range"
        If 指定オブジェクト.Cells.CountLarge = 1 Then ' 単独セルにはCurrentRegionを取る
            Set 対象セル範囲 = 指定オブジェクト.CurrentRegion
        Else
            Set 対象セル範囲 = 指定オブジェクト
        End If
    Case "Worksheet"
        Set 対象セル範囲 = 指定オブジェクト.UsedRange
    Case "AutoFilter", "ListObject"
        Set 対象セル範囲 = 指定オブジェクト.Range
    Case Else
        Err.Raise 1000, , "対象外のオブジェクト「" & TypeName(指定オブジェクト) & "」が指定されました。"
    End Select

    ' エリアの最終行を取得
    Get最終行 = 対象セル範囲.Rows.Count + 対象セル範囲.Row - 1

    ' 列が指定されていればその列の入力最終行を取得
    If C <> -1 Then
        Do While 対象セル範囲.Worksheet.Cells(Get最終行, C) = ""
            Get最終行 = Get最終行 - 1
            If Get最終行 < 対象セル範囲.Row Then
                Get最終行 = 0
                Exit Function
            End If
        Loop
    End If

End Function

' 最終列の取得
' 参考：https://www.limecode.jp/entry/library/get-lastrow-lastcolumn
Function Get最終列(指定オブジェクト As Variant, Optional ByVal R As Long = -1) As Long

    ' 渡されたオブジェクトからセル範囲を取得
    Dim 対象セル範囲 As Range
    Select Case TypeName(指定オブジェクト)
    Case "Range"
        If 指定オブジェクト.Cells.CountLarge = 1 Then ' 単独セルにはCurrentRegionを取る
            Set 対象セル範囲 = 指定オブジェクト.CurrentRegion
        Else
            Set 対象セル範囲 = 指定オブジェクト
        End If
    Case "Worksheet"
        Set 対象セル範囲 = 指定オブジェクト.UsedRange
    Case "AutoFilter", "ListObject"
        Set 対象セル範囲 = 指定オブジェクト.Range
    Case Else
        Err.Raise 1000, , "対象外のオブジェクト「" & TypeName(指定オブジェクト) & "」が指定されました。"
    End Select

    ' エリアの最終列を取得
    Get最終列 = 対象セル範囲.Columns.Count + 対象セル範囲.Column - 1

    ' 列が指定されていればその列の入力最終行を取得
    If R <> -1 Then
        Do While 対象セル範囲.Worksheet.Cells(R, Get最終列) = ""
            Get最終列 = Get最終列 - 1
            If Get最終列 < 対象セル範囲.Column Then
                Get最終列 = 0
                Exit Function
            End If
        Loop
    End If

End Function

' 値のコピー
' 参考：https://www.limecode.jp/entry/syntax/rangecopy-pastevalues
Sub 値をコピーする(コピー元基準セルまたはエリア As Range, ペースト基準セル As Range _
    , Optional ByVal エリア高 As Long = -1, Optional ByVal エリア幅 As Long = -1)
    
    ' ◇ エリアサイズの省略時は、コピーエリアのサイズを取得
    If エリア高 = -1 Then エリア高 = コピー元基準セルまたはエリア.Rows.Count
    If エリア幅 = -1 Then エリア幅 = コピー元基準セルまたはエリア.Columns.Count
    
    ' 値をコピー
    ペースト基準セル.Resize(エリア高, エリア幅).Value = コピー元基準セルまたはエリア.Resize(エリア高, エリア幅).Value

End Sub

解説

条件付き書式を判定する問題です。

条件付き書式がかかっているかどうかは、
対象RangeのDisplayFormatプロパティを調べることで判定できます。

ただしこれは「最終的に画面に表示されている書式」を取得するプロパティため、
通常の書式であってもこのプロパティに反映されます。

今回は「通常書式はない」という問題でしたので気にしなくていいですが、
通常書式がある可能性がある場合は、

If 対象セル.Font.Color <> 対象セル.DisplayFormat.Font.Color Then

このように「設定書式と表示書式が変わっているか」で判定を行ってください。

また、DisplayFormatは「テーブルの縞模様」も検知してしまいます。

テーブル上での判定は途端に難易度が上がってしまうため、
素直に条件付き書式と同じ判定式をIf文で作る解決策をおすすめします。

最後に、コード中に同じIf判定が何度も出てきていますが、
これは文字色と背景色二つの条件付き書式が合致したセルに対策するためです。

それぞれ別の判定をするとなると、データの転記を2度書く必要が出る上、
同じデータで合致した場合に2行にしない工夫も必要になります。

そうするくらいならIf文の重複を許容した感じですね。

このあたりは正解があるわけではありませんので、
いろいろ試して読みやすいコードを模索してみてください。