Delete rows in a range where a particular cell color is not present

[THEEND]

Hi,
I am still learning VBA and am trying to write some code that will delete all rows in the ActiveSheet.UsedRange where the cell color is not RGB(255, 255, 0), so the only remaining rows will those where this cell color appears.
Hope someone can advise - and many thanks in advance,
TE

 

[Anthony47]

If your color analysis can be limited to one specific column, you might try a "sort by color"; after the sorting it would not be complex to selected the rows that don't match yiur color and delete them.
Or try "filter by color"; then you "copy" the visible rows and copy them to a new sheet; this is my preferred option, as it leave untouched the starting datas for any audit need

Or is it necessary checking any of the cells in each of the rows?

 

[THEEND]

If your color analysis can be limited to one specific column, you might try a "sort by color"; after the sorting it would not be complex to selected the rows that don't match yiur color and delete them.
Or try "filter by color"; then you "copy" the visible rows and copy them to a new sheet; this is my preferred option, as it leave untouched the starting datas for any audit need

Or is it necessary checking any of the cells in each of the rows?

Thanks Anthony - this step is part of a much larger process - so what I am trying to do is determine if there are any yellow-colored cells present - if there are, delete all the non-yellow rows; if there are no yellow cells then Exit Sub.

 

[Anthony47]

Can the checking be limited to a specific column (on each of the rows) or is it necessary to check each of the columns (on each of the rows)?

 

[Anthony47]

if there are [yellow cells], delete all the non-yellow rows; if there are no yellow cells then Exit Sub.

Aren't these two conditions contraddicting each other?

 

[THEEND]

Aren't these two conditions contraddicting each other?

Apologies, I can see how that sounds contradictory - so, I want to check if there any yellow cells in the used range (this could be restricted to column A), if there are, then delete those rows that are not yellow, if there aren't any yellow cells then do nothing.

 

[Anthony47]

So if any row is marked in Yellow in column A, then keep only the marked rows; otherwise keep all.

Maybe the following macro:

Sub CkYellow()
Dim CCol As Long, TCol As String
Dim I As Long, R2K As Range, yCnt As Long
'
TCol = "B"                          '<<< The column to check
CCol = RGB(255, 255, 0)             '<<< 1-The color to check
'CCol = Range("H1").Interior.Color   '<<< 2-ALTERNATE METHOD
'
For I = 1 To Cells(Rows.Count, TCol).End(xlUp).Row
    If Cells(I, TCol).Interior.Color = CCol Then
        yCnt = yCnt + 1
    Else
        If R2K Is Nothing Then
            Set R2K = Rows(I)
        Else
            Set R2K = Application.Union(R2K, Rows(I))
        End If
    End If
Next I
If yCnt > 0 And Not R2K Is Nothing Then
    ActiveSheet.Copy after:=ActiveSheet     'AA-Original sheet backup copy
    Sheets(ActiveSheet.Index - 1).Select    'BB
    R2K.Delete
End If
End Sub

This works on the "ActiveSheet"

Copy the code to a Standard Module of your vba project; Look at the lines marked <<<, and change if necessary
Note that a copy of the original worksheet is created before deleting any line; if you don't want that, then remove the lines marked AA and BB in the code

Try...

 

[THEEND]

So if any row is marked in Yellow in column A, then keep only the marked rows; otherwise keep all.

Maybe the following macro:

Sub CkYellow()
Dim CCol As Long, TCol As String
Dim I As Long, R2K As Range, yCnt As Long
'
TCol = "B"                          '<<< The column to check
CCol = RGB(255, 255, 0)             '<<< 1-The color to check
'CCol = Range("H1").Interior.Color   '<<< 2-ALTERNATE METHOD
'
For I = 1 To Cells(Rows.Count, TCol).End(xlUp).Row
    If Cells(I, TCol).Interior.Color = CCol Then
        yCnt = yCnt + 1
    Else
        If R2K Is Nothing Then
            Set R2K = Rows(I)
        Else
            Set R2K = Application.Union(R2K, Rows(I))
        End If
    End If
Next I
If yCnt > 0 And Not R2K Is Nothing Then
    ActiveSheet.Copy after:=ActiveSheet     'AA-Original sheet backup copy
    Sheets(ActiveSheet.Index - 1).Select    'BB
    R2K.Delete
End If
End Sub

This works on the "ActiveSheet"

Copy the code to a Standard Module of your vba project; Look at the lines marked <<<, and change if necessary
Note that a copy of the original worksheet is created before deleting any line; if you don't want that, then remove the lines marked AA and BB in the code

Try...

That's brilliant - thank you so much, it works perfectly and is exactly what I was after.

Thanks again for all your help.

TE

 

[THEEND]

So if any row is marked in Yellow in column A, then keep only the marked rows; otherwise keep all.

Maybe the following macro:

Sub CkYellow()
Dim CCol As Long, TCol As String
Dim I As Long, R2K As Range, yCnt As Long
'
TCol = "B"                          '<<< The column to check
CCol = RGB(255, 255, 0)             '<<< 1-The color to check
'CCol = Range("H1").Interior.Color   '<<< 2-ALTERNATE METHOD
'
For I = 1 To Cells(Rows.Count, TCol).End(xlUp).Row
    If Cells(I, TCol).Interior.Color = CCol Then
        yCnt = yCnt + 1
    Else
        If R2K Is Nothing Then
            Set R2K = Rows(I)
        Else
            Set R2K = Application.Union(R2K, Rows(I))
        End If
    End If
Next I
If yCnt > 0 And Not R2K Is Nothing Then
    ActiveSheet.Copy after:=ActiveSheet     'AA-Original sheet backup copy
    Sheets(ActiveSheet.Index - 1).Select    'BB
    R2K.Delete
End If
End Sub

This works on the "ActiveSheet"

Copy the code to a Standard Module of your vba project; Look at the lines marked <<<, and change if necessary
Note that a copy of the original worksheet is created before deleting any line; if you don't want that, then remove the lines marked AA and BB in the code

Try...

One thing... is there a way to make the column range to check to be below row 1 so it retains the header, so from "B2" downwards instead of "B"?
Many thanks,
TE

 

[Anthony47]

To save row 1 don't start from I=1 but I = 2:

For I = 2 To Cells(Rows.Count, TCol).End(xlUp).Row

If that resolves the problem then it'd be better to mark the discussion as Resoved; see the procedure: Mark as Solution