Delete Rows based on Cells Color Criteria using VBA

[srkrish]

Hi Team,

Please help me with a solution for the below problem,

Need to retain a row and delete others for a given valid range, if atleast one cell in a row has filled with "Red" colour using VBA.

Sample is shown below,

Input:

1	2	3	4
5(Fill Red)	6	7	8
9	10	11	12
13	14(Fill Red)	15	16
17	18	19	20

<TBODY>
</TBODY>

Output:

5(Fill Red)	6	7	8
13	14(Fill Red)	15	16

<TBODY>
</TBODY>

Regards,
Sathish

 

[wigi]

For example:

Sub autofilter_red()

    With Cells(1).CurrentRegion
        For i = 1 To .Columns.Count
            .AutoFilter i, vbRed, xlFilterCellColor
        Next
    End With


End Sub

 

[wigi]

Hello

The previous code suggestion does not work, apologies.
This code copies the result to cell A1 on the second sheet of the file:

Sub autofilter_red()

    Dim rng As Range
    
    On Error Resume Next
    With Cells(1).CurrentRegion
        For i = 1 To .Columns.Count
            .AutoFilter
            .AutoFilter i, vbRed, xlFilterCellColor
            
            If Not rng Is Nothing Then
                Set rng = Application.Union(rng, .Columns(i).Offset(1).SpecialCells(xlCellTypeVisible))
            Else
                Set rng = .Columns(i).Offset(1).SpecialCells(xlCellTypeVisible)
            End If
            
        Next
        .AutoFilter
    End With


    If Not rng Is Nothing Then rng.EntireRow.Copy ThisWorkbook.Sheets(2).Cells(1)
        
End Sub

 

[srkrish]

Hi Wigi,

Thanks for the code. It works fine when there is only one cell in a row is filled with "Red", but if I have rows with more than one cell highlighted with "Red" then the code doesn't
function as expected. Please advise.

Regards,
Sathish

 

[wigi]

With the help of 2 custom functions:

Sub autofilter_red()

    Dim rng As Range, rng_2 As Range


    On Error Resume Next
    With Cells(1).CurrentRegion
        For i = 1 To .Columns.Count
            .AutoFilter
            .AutoFilter i, vbRed, xlFilterCellColor
            Set rng = Union2(rng, .Columns(i).Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible))
        Next
        .AutoFilter
    End With
    On Error GoTo 0


    With ThisWorkbook.Sheets(2)
        If Not rng Is Nothing Then
            .Cells(1).Resize(, Cells(1).CurrentRegion.Columns.Count) = Cells(1).CurrentRegion.Rows(1).Value
            Set rng = ProperUnion(rng, Application.Intersect(rng.EntireRow, Cells(1).CurrentRegion))
            For Each rng_2 In rng.Areas
                rng_2.Copy .Cells(1).Offset(.UsedRange.Rows.Count)
            Next
        End If
    End With


End Sub


Function ProperUnion(ParamArray Ranges() As Variant) As Range
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ProperUnion
' This provides Union functionality without duplicating
' cells when ranges overlap. Requires the Union2 function.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim ResR As Range
    Dim N As Long
    Dim R As Range


    If Not Ranges(LBound(Ranges)) Is Nothing Then
        Set ResR = Ranges(LBound(Ranges))
    End If
    For N = LBound(Ranges) + 1 To UBound(Ranges)
        If Not Ranges(N) Is Nothing Then
            For Each R In Ranges(N).Cells
                If Application.Intersect(ResR, R) Is Nothing Then
                    Set ResR = Union2(ResR, R)
                End If
            Next R
        End If
    Next N
    Set ProperUnion = ResR
End Function


Function Union2(ParamArray Ranges() As Variant) As Range
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Union2
' A Union operation that accepts parameters that are Nothing.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim N As Long
    Dim RR As Range
    For N = LBound(Ranges) To UBound(Ranges)
        If IsObject(Ranges(N)) Then
            If Not Ranges(N) Is Nothing Then
                If TypeOf Ranges(N) Is Excel.Range Then
                    If Not RR Is Nothing Then
                        Set RR = Application.Union(RR, Ranges(N))
                    Else
                        Set RR = Ranges(N)
                    End If
                End If
            End If
        End If
    Next N
    Set Union2 = RR
End Function

 

[srkrish]

Hi Wigi,

Thanks a lot for the code and it did help to me complete my task.

Regards,
Sathish