Filter by color of Cell ? formula/vba code ?

[RompStar]

Is there anyway to filter a column instead by the information that's in the cell and rather by the color of the cell ?

Like if column B has some of the cell background as red, how do I filter for that by color ?

Or maybe a formula that will copy the contents of cells with red color into a different column ? like Autofilter by color maybe ?

Please let me know, maybe there is some simple VBA code that will look at column B and copy maybe all rows that have red color in column B.

Thanks!!!

 

[Oaktree]

I think you have to do this in two steps:

1) create a column which identifies the colorindex of each cell (see http://www.cpearson.com/excel/colors.htm for a UDF)

2) filter based on the results of the column from #1 above

 

[DominicB]

Good evening RompStar

You could use Ron de Bruin's EasyFilter add-in. It can filter by colours and loads of other different ways that Excel normally can't, and it's free :

http://www.rondebruin.nl/easyfilter.htm

HTH

DominicB

 

[Joe Was]

Public myCount As Long

Sub myColor()
'Sheet module code, like: Sheet1.
Dim myRowNum As Long

myRowNum = ActiveSheet.UsedRange.Rows.Count
Selection.Select

Do Until Selection.Row = myRowNum + 1
'Find red text.
If Selection.Font.ColorIndex = 3 Then
'To select entire row, un-comment below!
'Selection.EntireRow.Select
GoTo mySelect
Else
Selection.Offset(1, 0).Select
End If
Loop
End
mySelect:

End Sub

'This custom function will count all the red text cell in the current selection.

'"Public myCount As Long"
'Above must be the first line in the module.
'This could go into a Sheet Module or a standard module.

Sub CheckCells(CurrRange As Range)
'Sheet module code, like: Sheet1.
Dim myRange As Range

'This Function will count colored text cells.
myCount = 0
Set myRange = Selection
For Each Cell In myRange
'3=red colored text.
'You can change the code value as needed.
If Cell.Font.ColorIndex = 3 Then myCount = myCount + 1 Else
Next Cell
End Sub

Sub redCount()
'Sheet module code, like: Sheet1.
Dim myRange As Range

'This is the calling sub "redCount."
'You must select the area to count colored text in!
Selection.Select
Set myRange = Selection
Call CheckCells(myRange)
'This is the message box with the count.
'You can report myCount anyway you want.
MsgBox "The total number of red cells," & Chr(13) & _
"in your current selection are: " & Chr(13) & Chr(13) _
& " [ " & myCount & " ]"
End Sub

 

[erik.van.geit]

Hi,

some months ago we discussed here on the forum with NateO
he pointed to a system based on Excel4 macro (whatever this might be)
main advantage is "speed" !
no loop involved
(last code has loop, because of multiple colors)
the one specific for this thread, is the second code

Sub count_by_color()
Application.ScreenUpdating = False
ThisWorkbook.Names.Add Name:="Color", RefersToR1C1:="=GET.CELL(63,!RC[-1])"
    With Worksheets(1)
        With .Range(.Cells(1, 2), .Cells(.Rows.Count, 1).End(xlUp)(1, 2))
        .Formula = "=Color"
        '.Offset(, -1).Resize(, 2).Sort Key1:=.Item(1, 1), Order1:=xlAscending, Header:=xlNo
        MsgBox Application.CountIf(.Offset(0, 0), 3) & " red cells"
        .ClearContents
        End With
    End With
ThisWorkbook.Names("Color").Delete
Application.ScreenUpdating = True
End Sub

Sub sum_by_color()
'assuming values are in column 1
'column 2 is used to calculate
'result in C1
Dim LR As Long

Application.ScreenUpdating = False
ThisWorkbook.Names.Add Name:="Color", RefersToR1C1:="=GET.CELL(63,!RC[-1])"
    With Worksheets(1)
    LR = .Cells(.Rows.Count, 1).End(xlUp).Row
        With .Range(.Cells(1, 2), .Cells(LR, 2))
        .Formula = "=Color"
        .Offset(0, 1)(1) = Evaluate("=SUMIF(B1:B" & LR & ",3,A1:A" & LR & ")")
        .ClearContents
        End With
    End With
ThisWorkbook.Names("Color").Delete
Application.ScreenUpdating = True
End Sub

I worked out a solution to get all colors calculated

Option Explicit

Sub sum_by_color()
'Erik Van Geit
'060802
'create list with sums of all available backcolors in previous column
'EXAMPLE (R = Red cell, B = Blue, Y = Yellow)
'VALUES RESULT
'R 12   R 99
'R 15   B 32
'B 10   Y 44
'R 70
'Y 44
'B 22

Dim LR   As Long  'Last Row
Dim rng1 As Range
Dim rng2 As Range
Dim c    As Range

'EDIT next two lines
Const col = 1   'Column
Const HR = 1    'Header Row (first row with data will be HR +1)

Application.ScreenUpdating = False
ThisWorkbook.Names.Add Name:="Color", RefersToR1C1:="=GET.CELL(63,!RC[-1])"

    With Worksheets(1)
    
    LR = .Cells(.Rows.Count, col).End(xlUp).Row
        If LR - HR < 1 Then
        MsgBox "No data available", 48, "CANCELED"
        Exit Sub
        End If

        With .Columns(col + 1)
        .Clear
        .Insert
        End With
    
    Set rng1 = .Range(.Cells(HR, col + 1), Cells(LR, col + 1))
        With rng1
        .Formula = "=Color"
        .Value = .Value
        .AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Offset(0, 1), Unique:=True
        End With
        
    Set rng2 = .Range(.Cells(HR + 1, col + 2), .Cells(.Rows.Count, col + 2).End(xlUp))
    'rng2.Sort key1:=rng2(1), order1:=xlAscending
        For Each c In rng2
            With c
            .Interior.ColorIndex = .Value
            .Value = Evaluate("=SUMIF(" & rng1.Address & "," & .Value & "," & rng1.Offset(0, -1).Address & ")")
            End With
        Next c
        
        .Columns(col + 1).Delete
        Cells(HR, col + 1) = "RESULT"

    End With
    
    
ThisWorkbook.Names("Color").Delete
Application.ScreenUpdating = True

End Sub

kind regards,
Erik