トップ　>　汎用コード　>　指定の色のセルを一括取得

'-----------------------------------------------------------------------
' 実行マクロ
'-----------------------------------------------------------------------
Sub ExampleOfUse_GetCellsWithSpecifiedColor()

    '色の指定
    Dim lngColor As XlRgbColor
    lngColor = rgbRed '赤を指定　RGB関数を使用する例：lngColor = RGB(255, 0, 0)

    'プロシージャを実行
    Dim rngResult As Range
    Set rngResult = GetCellsWithSpecifiedColor(ActiveSheet.Cells, lngColor)
    
    '結果表示
    If rngResult Is Nothing Then
        MsgBox "該当のセルは見つかりませんでした", vbInformation
    Else
        MsgBox "セル個数：" & rngResult.Cells.CountLarge & vbLf & _
               "セルアドレス：" & rngResult.Address(False, False), _
               vbInformation
        '色を一括でクリアする場合には次の行をコメントアウトにする
        'rngResult.Interior.Color = xlNone
    End If
End Sub

'-----------------------------------------------------------------------
' 対象セル範囲の中から指定の色のセルを取得するプロシージャ
'-----------------------------------------------------------------------
'［引数］
'   Target：検索対象セル範囲
'   Color ：文字列に設定する色番号
'［戻り値］
'   検索に一致したセルの集合
'   検索に一致したセルがないやエラーの場合はNothing
'［作成日］2023/06/18
'https://excel.syogyoumujou.com/vba/GetCellsWithSpecifiedColor.html
'-----------------------------------------------------------------------
Function GetCellsWithSpecifiedColor(ByVal Target As Range, _
                                    ByVal Color As XlRgbColor) As Range
                               
    On Error GoTo ERROR_HANDLER
                               
    'Target にセルが設定されていなければ抜ける
    If Target Is Nothing Then Exit Function
    
    '対象セル範囲を最適化
    Set Target = Application.Intersect(Target, Target.Parent.UsedRange)
    
    'Target にセルが設定されていなければ抜ける
    If Target Is Nothing Then Exit Function
    
    '書式検索の設定
    With Application.FindFormat
        .Clear
        .Interior.Color = Color
    End With
    
    '検索値を格納
    Dim varWhat As Variant
    varWhat = Array("", "*")
    
    '検索開始
    Dim i          As Long
    Dim strAddress As String
    Dim rngFnd     As Range
    Dim rngUnion   As Range
    For i = LBound(varWhat) To UBound(varWhat)
    
        '対象セル範囲を指定のセル背景色で検索
        Set rngFnd = Target.Find(What:=varWhat(i), SearchFormat:=True)

        If Not rngFnd Is Nothing Then
            '最初のセルのアドレス格納
            strAddress = rngFnd.Address
            
            '集合用のセルにセルを設定
            If rngUnion Is Nothing Then
                Set rngUnion = rngFnd
            Else
                Set rngUnion = Union(rngUnion, rngFnd)
            End If
            
            Do
                '次のセルを検索
                Set rngFnd = Target.Find(What:=varWhat(i), _
                                         After:=rngFnd, _
                                         SearchFormat:=True)
                '最初のセルとアドレスが同じの場合は抜ける
                If rngFnd.Address = strAddress Then Exit Do
                
                '新たに見つかったセルを集合する
                Set rngUnion = Union(rngUnion, rngFnd)
            Loop
            
        End If
    Next

    Set GetCellsWithSpecifiedColor = rngUnion
    
    On Error GoTo 0
    Exit Function
ERROR_HANDLER:
End Function