delete all cells of a certain color

user_9370341 0
Viewed 5261

This seems relatively simple and as I understand, it is possible. But I can't seem to figure it out or find exactly what I am looking for on the internet.

I have some excel data in column A and some of the data is blue (0,0,255), some is red (255,255,255), some is green (0, 140, 0). I want to delete all blue data.

I was told that:

Sub test2()
    Range("A2").DisplayFormat.Font.Color
End Sub

Would give me the colors... but when I run that it says invalid use of the property and highlights .color

Instead I clicked on the: Font color drop down then more colors then custom colors then I can see that the data in blue is at (0,0,255)

So then I tried:

Sub test()

Dim wbk As Workbook
Dim ws As Worksheet
Dim i As Integer
Set wbk = ThisWorkbook
Set ws = wbk.Sheets(1)

Dim cell As Range

With ws
    For Each cell In ws.Range("A:A").Cells
        'cell.Value = "'" & cell.Value
        For i = 1 To Len(cell)
            If cell.Characters(i, 1).Font.Color = RGB(0, 0, 255) Then
                If Len(cell) > 0 Then
                    cell.Characters(i, 1).Delete
                End If
                If Len(cell) > 0 Then
                    i = i - 1
                End If
            End If
        Next i
    Next cell
End With

End Sub

I found this on the web as a solution in several places but when I run it, nothing seems to happen.

fonts vba excel colors
4 Answers

This is basic, if your cells with blue font are not deleted then the font is a different color. Change the range to meet your needs.

For Each cel In ActiveSheet.Range("A1:A30")
    If cel.Font.Color = RGB(0, 0, 255) Then cel.Delete
Next cel

Updated to allow user to select the first cell in the column with the font color, obtain the font color, and clear all the cells that match the font color.

Dim rng As Range
Set rng = Application.InputBox("Select a Cell:", "Obtain Range Object", Type:=8)

    With ActiveSheet
        Dim lr As Long
        lr = Cells(Rows.Count, 1).End(xlUp).Row

        Dim x As Long
        x = rng.Row

        For i = lr To x Step -1
            If .Cells(i, 1).Font.Color = rng.Font.Color Then .Cells(i, 1).Clear
        Next i
    End With
user_63886980

Something like following where all qualifying cells are gathered together, using Union, and deleted in one go. If deleting entire rows individually, you always need to loop backwards. Deleting/clearing in one go is more efficient.

Sub test()
    Dim wbk As Workbook, ws As Worksheet
    Dim i As Long, currentCell As Range, unionRng As Range

    Set wbk = ThisWorkbook
    Set ws = wbk.Worksheets("Sheet1")

    With ws
        For Each currentCell In .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)  '<==assuming actual data present
            If  currentCell.Font.Color = RGB(0, 0, 255) Then
                If Not unionRng Is Nothing Then
                    Set unionRng = Union(currentCell, unionRng)
                Else
                    Set unionRng = currentCell
                End If
            End If
        Next
    End With
    If Not unionRng Is Nothing Then unionRng.Delete
End Sub

user_62412350

you coudl use Range object Autofilter() method with xlFilterFontColor operator;

Sub test()       
    With ThisWorkbook.Sheets(1)
        With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
            .AutoFilter Field:=1, Criteria1:=RGB(0, 0, 255), Operator:=xlFilterFontColor
            If Application.WorksheetFunction.Subtotal(103, .Cells) > 0 Then .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).ClearContents
        End With
        .AutoFilterMode = False
        If .Range("A1").Font.Color = RGB(0, 0, 255) Then .Range("A1").ClearContents ' check first row, too (which is excluded by AutoFilter)
    End With
End Sub
user_93128920 
Option Explicit
Sub test2()

Dim cel As Range
Dim LR As Long

LR = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row

For Each cel In ActiveSheet.Range("A1:A" & LR)

    If cel.Font.Color = RGB(0, 0, 255) Then cel.ClearContents
Next cel
End Sub
user_93703410
Related