Filter by color of Cell ? formula/vba code ?

RompStar

Well-known Member
Joined
Mar 25, 2005
Messages
1,200
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 ? :unsure:

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!!!
 

Some videos you may like

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.

Joe Was

MrExcel MVP
Joined
Feb 19, 2002
Messages
7,539
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

MrExcel MVP
Joined
Feb 1, 2003
Messages
17,832
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
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
Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,114,407
Messages
5,547,766
Members
410,811
Latest member
adustin42
Top