VBA ค้นหาสีแดง

[mr.zatan]

ต้องการค้นหาสีแดงครับ ค้นหาแบบ Find Next ไปทีล่ะอัน วนไปเรื่อยๆ

Code: Select all

Sub SelectColoredCells()
    Dim rCell As Range
    Dim lColor As Long
    Dim rColored As Range

    lColor = RGB(255, 0, 0)


    Set rColored = Nothing
    For Each rCell In Selection
        If rCell.Interior.Color = lColor Then
            If rColored Is Nothing Then
                Set rColored = rCell
            Else
                Set rColored = Union(rColored, rCell)
            End If
        End If
    Next
    If rColored Is Nothing Then
        MsgBox "No cells match the color"
    Else
        rColored.Select
        MsgBox "Selected cells match the color:" & _
            vbCrLf & rColored.Address
    End If
    Set rCell = Nothing
    Set rColored = Nothing
End Sub

[snasui]

แนบไฟล์ตัวอย่างมาด้วยจะได้ทดสอบและปรับปรุง Code ให้ได้ครับ

[mr.zatan]

แนบไฟล์มาแล้วครับ

[astalavista]

Code: Select all

    Dim lColor As Long
    lColor = RGB(255, 0, 0)
    
    Application.FindFormat.Interior.Color = lColor

    Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
    xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
    , SearchFormat:=True).Activate
    
    Application.FindFormat.Clear

[mr.zatan]

เวลาไม่มีสีแดงจะขึ้นว่า " Object variable or With block variable not set " ครับ

Code: Select all

Sub SelectColoredCells()
    Dim rCell As Range
    Dim lColor As Long
    Dim rColored As Range

    lColor = RGB(255, 0, 0)
 Application.FindFormat.Interior.Color = lColor

    Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
    xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
    , SearchFormat:=True).Activate
    
    Application.FindFormat.Clear


    Set rColored = Nothing
    For Each rCell In Selection
        If rCell.Interior.Color = lColor Then
            If rColored Is Nothing Then
                Set rColored = rCell
            Else
                Set rColored = Union(rColored, rCell)
            End If
        End If
    Next
    If rColored Is Nothing Then
        MsgBox "No cells match the color"
    Else
        rColored.Select
        MsgBox "Selected cells match the color:" & _
            vbCrLf & rColored.Address
    End If
    Set rCell = Nothing
    Set rColored = Nothing
End Sub

[astalavista]

Code: Select all

Sub SelectColoredCells()
    Dim lColor As Long
    Dim rCell As Range
    lColor = RGB(255, 0, 0)
    
    Application.FindFormat.Interior.Color = lColor

    Set rCell = Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
    xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
    , SearchFormat:=True)
    If Not rCell Is Nothing Then
        rCell.Activate
        Else
        MsgBox "No cells match the color"
    End If
    Application.FindFormat.Clear
End Sub

[mr.zatan]

ขอบคุณครับ