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

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.

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
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,168,129
Messages
5,857,542
Members
431,885
Latest member
Rsdg

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top