I want to sum by color in excel, I try two codes: one for only red color and another for any color. The second does not work
Function SumColor(MatchColor As Range, sumRange As Range) As Double
Dim cell As Range
Dim myColor As Long
myColor = MatchColor.Cells(1,1).Interior.Color
For Each cell In sumRange
If cell.Interior.Color = myColor Then
SumColor = SumColor + cell.Value
End If
Next cell
End Function
Related
I am using the below code to select the colored cells (Yellow) on usedrange.
In the same sheet I have other cells filled with another different colors.
I am asking, is it possible to use Application.FindFormat to find all the other different format (Color)?
I tried to use :
Application.FindFormat.Interior.Color <> vbYellow
But I got syntax error. In advance, grateful for all your help.
Sub Answer()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim crg As Range
Set crg = ws.UsedRange
Application.FindFormat.Interior.Color = vbYellow
Dim rg As Range, c As Variant, FirstAddress As Variant
Set c = crg.Find(What:=vbNullString, SearchFormat:=True)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
If rg Is Nothing Then
Set rg = c
Else
Set rg = Union(rg, c)
End If
Set c = crg.Find(What:=vbNullString, after:=c, SearchFormat:=True)
Loop While c.Address <> FirstAddress
rg.Select
Else
MsgBox "no cell with yellow color found"
End If
End Sub
The Application.FindFormat in Excel/VBA can do exactly the same as the Find-Dialog in Excel. As you can see, there is no "not equal" search in Excel for formatting, so there is no such search in VBA.
To get a list of colors and it's usage, you will have to loop over all cells. The following code builds a dictionary of colors and it's usage and dumps the result to the immediate window. Call it for example with ListAllColors ws.UsedRange
Sub ListAllColors(r As Range)
Dim colorList As Object
Set colorList = CreateObject("Scripting.Dictionary")
Dim cell As Range
For Each cell In r
Dim color
If cell.Interior.ColorIndex <> xlNone Then
color = cell.Interior.color
If colorList.exists(color) Then
' Color already in List, add cell to Range
Dim colorRange As Range
Set colorRange = colorList(color)
Set colorList(color) = Union(colorRange, cell)
Else
' New color, add entry to Dict
colorList.Add color, ""
' Ensure that the content is set to the cell itself, not the value.
Set colorList(color) = cell
End If
End If
Next
' Dump the result
For Each color In colorList.keys
Dim red As Long, green As Long, blue As Long
Call getRGB(CLng(color), red, green, blue)
Debug.Print color, "R:" & red, "G:" & green, "B:" & blue, colorList(color).Address
Next
End Sub
' Split color into it's red, green and blue parts
Public Sub getRGB(color As Long, ByRef red As Long, ByRef green As Long, ByRef blue As Long)
red = color And vbRed
green = (color And vbGreen) \ &H100
blue = (color And vbBlue) \ &H10000
End Sub
Update
To get a range of all colored cells, you can simplify the code, you will still have to loop over all cells, but can immediately build the union. Have a look to the following function. I added an optional parameter so you can ignore all cells with a certain color (eg vbYellow).
Function GetColoredCells(r As Range, Optional IgnoreColor As Long = -1) As Range
Dim cell As Range
For Each cell In r
Dim color
If cell.Interior.ColorIndex <> xlNone And cell.Interior.color <> IgnoreColor Then
If GetColoredCells Is Nothing Then
Set GetColoredCells = cell
Else
Set GetColoredCells = Union(GetColoredCells, cell)
End If
End If
Next
End Function
To omit the first line, call the function for example like that:
Set rg = GetColoredCells(ws.UsedRange.Offset(1, 0), vbYellow)
I've found this piece of code online and tried to modify it to do what i want. It works in a very basic way, where you assign it as a macro to a Form button, to find duplicates in 6 seperate columns, but is there a way of tidying up the code, and possibly automating it, so i don't have to press a form button to run the macro every time ?
Sub Check_Dups()
'Declaring variables
Dim Cell As Variant
Dim Source As Range
Dim Source2 As Range
Dim Source3 As Range
Dim Source4 As Range
Dim Source5 As Range
Dim Source6 As Range
'Initializing source range
Set Source = Range("E8:E105")
Set Source2 = Range("F8:F105")
Set Source3 = Range("G8:G105")
Set Source4 = Range("H8:H105")
Set Source5 = Range("I8:I105")
Set Source6 = Range("J8:J105")
'Removing any previous formatting from the source
Source.Interior.Color = RGB(255, 255, 255)
Source2.Interior.Color = RGB(255, 255, 255)
Source3.Interior.Color = RGB(255, 255, 255)
Source4.Interior.Color = RGB(255, 255, 255)
Source5.Interior.Color = RGB(255, 255, 255)
Source6.Interior.Color = RGB(255, 255, 255)
'Looping through each cell in the source range
For Each Cell In Source
'Checking whether value in cell already exist in the source range
If Application.WorksheetFunction.CountIf(Source, Cell) > 1 Then
'Highlighting duplicate values in red color
Cell.Interior.Color = RGB(255, 0, 0)
End If
Next
'Looping through each cell in the source range
For Each Cell In Source2
'Checking whether value in cell already exist in the source range
If Application.WorksheetFunction.CountIf(Source2, Cell) > 1 Then
'Highlighting duplicate values in red color
Cell.Interior.Color = RGB(255, 0, 0)
End If
Next
'Looping through each cell in the source range
For Each Cell In Source3
'Checking whether value in cell already exist in the source range
If Application.WorksheetFunction.CountIf(Source3, Cell) > 1 Then
'Highlighting duplicate values in red color
Cell.Interior.Color = RGB(255, 0, 0)
End If
Next
'Looping through each cell in the source range
For Each Cell In Source4
'Checking whether value in cell already exist in the source range
If Application.WorksheetFunction.CountIf(Source4, Cell) > 1 Then
'Highlighting duplicate values in red color
Cell.Interior.Color = RGB(255, 0, 0)
End If
Next
'Looping through each cell in the source range
For Each Cell In Source5
'Checking whether value in cell already exist in the source range
If Application.WorksheetFunction.CountIf(Source5, Cell) > 1 Then
'Highlighting duplicate values in red color
Cell.Interior.Color = RGB(255, 0, 0)
End If
Next
'Looping through each cell in the source range
For Each Cell In Source6
'Checking whether value in cell already exist in the source range
If Application.WorksheetFunction.CountIf(Source6, Cell) > 1 Then
'Highlighting duplicate values in red color
Cell.Interior.Color = RGB(255, 0, 0)
End If
Next
End Sub
Some other ways to automate a macro are WorkSheet_Change and Workbook_Open events, but I would stick with Button_Click to initiate your macro.
The below code can be use to loop through the range in each column and color duplicate values using AutoFilter. If you want to color each group a different color, you can use the randomized RGB line of code.
Sub ColorDuplicates_wRGB()
'This macro loops thru each cell, if the cell has duplicates in the range, it filters the range using the cell value,
'then colors the visible cells in the range Red or with a unique color using RGB Colors.
'xlNone in the If statement, skips previous colored cells.
'Works with both sorted and unsorted data.
Dim ws As Worksheet, rng As Range, cel As Range, colr As String, i As Long 'Define your variables
Application.ScreenUpdating = False 'I hate to see the screen flickering
Set ws = ThisWorkbook.Sheets("Sheet1") 'identify the worksheet variable; you will need to change the sheet reference
For i = 5 To 9 'To loop through each column
Set rng = ws.Range(ws.Cells(8, i), ws.Cells(105, i))
rng.Interior.ColorIndex = xlNone 'clear interior color for all cells in range
For Each cel In rng 'Loop
If WorksheetFunction.CountIf(rng, cel.Value) > 1 And cel.Interior.ColorIndex = xlNone Then
'Filter using cel.Value
rng.AutoFilter field:=1, Criteria1:=cel.Value
colr = RGB(255, 0, 0)
'If you want different colors for each duplicate group use the next line
'colr = RGB(Int((255 - 1 + 1) * Rnd() + 1), Int((255 - 1 + 1) * Rnd() + 1), Int((255 - 1 + 1) * Rnd() + 1))
'Select the visible cells in range and color, the -1 removes the blank row at the end caused by Offset
rng.Offset(1).Resize(rng.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Interior.Color = colr
rng.AutoFilter 'reset filter
End If
Next cel
Next i
Application.ScreenUpdating = True
End Sub
I am trying to count the number of cells that have a blue font and It won't work. I can count cells with a red font but not blue. This is a custom function I have created using VBA
Function GetFontColorCount(CountRange As Range, CountColor As Range)
Dim CountColorValue As Integer
Dim TotalCount As Integer
CountColorValue = CountColor.Font.Color
Set rCell = CountRange
For Each rCell In CountRange
If rCell.Font.Color = CountColorValue And rCell.Value >= 1 Then
TotalCount = TotalCount + 1
End If
Next rCell
GetFontColorCount = TotalCount
End Function
When using the formula It will count red font and black but not blue or any of the other colors that I have tried.
The following procedures assume that the target range is in E6: I18 and that a sample range is used that contains each of the font colors to be counted (the sample range is inB2: B5)
Sub GetFontColorCount_TEST()
Dim rTrg As Range
Dim rColor As Range
Dim rCll As Range
Rem Set Ranges
With ThisWorkbook.Worksheets("DATA") 'Update as required
Set rTrg = .Range("E6:I18") 'Update as required
Set rColor = .Range("B2:B5") 'Update as required
End With
Rem Get Font Color Count and enter the value besides the sample cell
For Each rCll In rColor
rCll.Offset(0, 1).Value2 = Range_ƒFontColor_Count(rTrg, rCll)
Next
End Sub
.
Function Range_ƒFontColor_Count(rTrg As Range, rColor As Range)
Dim lColor As Long
Dim lColorCnt As Byte
Dim rCll As Range
Rem Set sample Font Color
lColor = rColor.Font.Color
Rem Count cells with sample Font Color
For Each rCll In rTrg.Cells
If rCll.Font.Color = lColor Then lColorCnt = 1 + lColorCnt
Next
Range_ƒFontColor_Count = lColorCnt
End Function
I found a macro which counts conditionally formatted coloured cells.
'Variable declaration
Dim lColorCounter2 As Long
Dim rngCell2 As Range
'loop throughout each cell in the range
For Each rngCell2 In Selection
'Checking Amber color
If Cells(rngCell2.Row, rngCell2.Column).DisplayFormat.Interior.Color = RGB(255, 192, 0) Then
lColorCounter2 = lColorCounter2 + 1
End If
Next
MsgBox "Green =" & lColorCounter2
I am trying to change it into a function. I've read on here that it may be because .DisplayFormat.Interior.Color doesn't work for functions. Is there a workaround?
Ideally I would like the function to have two arguments, the range of cells to search in for the colours and the second a cell with the colour to look for.
Have in mind that:
RGB(255, 192, 0) is not green but close to orange.
Change the range you want to loop - rng (now rng equals to Sheet1.Range("A1:A20"))
Try:
Option Explicit
Public Function Color(ByVal rng As Range)
Dim Counter As Long
Dim Cell As Range
For Each Cell In rng
'Checking Amber color
If Cells(Cell.Row, Cell.Column).DisplayFormat.Interior.Color = RGB(255, 192, 0) Then
Counter = Counter + 1
End If
Next
MsgBox "Orange=" & Counter
End Function
Sub test()
Dim rng As Range
Set rng = Sheet1.Range("A1:A20")
Call Color(rng)
End Sub
I have an Excel range with the 8 color constants. I just wanted to simply change the interior color of the cell in the adjacent column based on the cell value. Unfortunately, I get a type mismatch which is because it is treating the value as a string, but I don't know how to convert it to constant.
For example, to change interior color to blue this works
rng.interior.color = vbblue
but not this
rng.interior.color = rng.value 'because it is a string "vbblue"
What can I do to convert rng.value from string to the color constant so the range in column E gets background color based on value in column D?
Dim colorRange As Range
Dim rng As Range
Set colorRange = Range("D1", Range("D1").End(xlDown).Address)
For Each rng In colorRange
rng.Offset(, 1).Interior.Color = rng.Value
Next rng
There is no "built-in" way to convert the name of a Constant to its value. You need to do the mapping yourself. Best is to use a dictionary:
Function TextToColor(s As String) As Long
Static dict As Dictionary
If dict Is Nothing Then
Set dict = CreateObject("Scripting.Dictionary")
dict("vbBlack") = vbBlack
dict("vbWhite") = vbWhite
dict("vbRed") = vbRed
dict("vbGreen") = vbGreen
dict("vbBlue") = vbBlue
dict("vbYellow") = vbYellow
dict("vbMagenta") = vbMagenta
dict("vbCyan") = vbCyan
' dict("etc...") = etc...
End If
TextToColor = dict(s)
End Function
Sub ExampleUse()
Dim colorRange As Range: Set colorRange = Range("D1", Range("D1").End(xlDown).Address)
Dim rng As Range
For Each rng In colorRange
rng.Offset(, 1).Interior.Color = TextToColor(rng.value)
Next rng
End Sub
You can do it directly with ColorIndex instead. So if the cell says 5 or the related color index number, there's no need to change the code other than this line:
rng.Offset(, 1).Interior.ColorIndex = rng.Value