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
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 need to create a script that will type a value into every colored cell in a given range
I am very new to all of this so forgive my ignorance.
From the reading I've done I've come up with this
Sub Macro1()
Dim colors As Range, found As Boolean
Set colors = ActiveSheet.Range("D19:CV68")
found = VBA.IsNull(colors.DisplayFormat.Interior.ColorIndex)
colors = IIf(found, "1", " ")
End Sub
This gets me very close to what I need but instead of placing the 1 in just the colored cells it places the one in every cell in the range.
I'm sure there is a very basic way to do this that I am just not aware of.
I appreciate any help that I can get.
Thanks!
You need to iterate through each cell in the range testing for no color.
Dim colors As Range
Dim cell As Range
Set colors = Range("D19:CV68")
For Each cell In colors
If cell.Interior.ColorIndex = xlColorIndexNone Then
cell.Value = ""
Else
cell.Value = 1
End If
Next cell
Fill Colored Cells of a Range
Adjust the values in the constants section.
Sub FillColored()
Const rgAddress As String = "D19:CV68"
Const nStr As String = ""
Const yStr As String = "1"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim rg As Range: Set rg = ws.Range(rgAddress)
Dim yrg As Range
Dim nrg As Range
Dim cel As Range
For Each cel In rg.Cells
If cel.DisplayFormat.Interior.ColorIndex = xlNone Then
If nrg Is Nothing Then Set nrg = cel Else Set nrg = Union(nrg, cel)
Else
If yrg Is Nothing Then Set yrg = cel Else Set yrg = Union(yrg, cel)
End If
Next cel
If Not nrg Is Nothing Then nrg.Value = nStr
If Not yrg Is Nothing Then yrg.Value = yStr
End Sub
Excel highlight cells with the same value in colors
I need a macro that will color all duplicate cells with colors,
I need to color the cells in different colors, to Cell A2 and Cell A3 can have the same value like 50, and Cell A4 and A5 can have the value of 60, And Cell A7,A8 and A9 can have tha value of 40, or Cell A11, A15 and A20 can have tha value of 250.
I need the colors to not be the same if the value is different so Cells A2 and A3 can be yellow if the value is duplicate , then Cell A4 and A5 can be Orange, Cells A7, A8 and A9 can be yellow.
The problem is that it I can have an Excel files from 10 cells to 600 cells, So It can take forever to do manually.
I have a macro that can color in this way, but I need to be able to read tha value i the colored cells, something my macro can't do.
Is it possible to do something like this in VBA?
VBA Code:
Dim ws As Worksheet
Dim clr As Long
Dim rng As Range
Dim cell As Range
Dim r As Range
Set ws = ThisWorkbook.Sheets(ActiveSheet.Name)
Set rng = ws.Range("A2:a" & Range("A" & ws.Rows.Count).End(xlUp).Row)
With rng
Set r = .Cells(.Cells.Count)
End With
rng.Interior.ColorIndex = xlNone
clr = 3
For Each cell In rng
If Application.WorksheetFunction.CountIf(rng, cell) > 1 Then
'addresses will match for first instance of value in range
If rng.Find(What:=cell, LookAt:=xlWhole, MatchCase:=False, After:=r).Address = cell.Address Then
'set the color for this value (will be used throughout the range)
cell.Interior.ColorIndex = clr
clr = clr + 1
Else
'if not the first instance, set color to match the first instance
cell.Interior.ColorIndex = rng.Find(What:=cell, LookAt:=xlWhole, MatchCase:=False, After:=r).Interior.ColorIndex
End If
End If
Next
End Sub
If all you want to do is have an alternating color like in the picture, you only need to change the row clr = clr + 1 to something like the following.
If clr = 44 Then
clr = 45
Else
clr = 44
End If
Those are an estimation of the color in the picture. You also want to change clr = 3 to clr = 44 or whatever color you and up using.
If the numbers are sorted ascending or descending (like in your image) then you can do this much faster than using the find method.
Option Explicit
Public Sub ColorDuplicatesAlternate()
Dim ws As Worksheet ' define your sheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long ' find last used row
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim DataRange As Range ' read data range
Set DataRange = ws.Range("A1", "A" & LastRow + 1)
Dim DataValues() As Variant ' read data into array for fast processing
DataValues = DataRange.Value
Dim iStart As Long
iStart = 1
Dim BlockValue As Variant
Dim IsEven As Boolean
Dim EvenBlocks As Range
Dim OddBlocks As Range
Dim CurrentBlock As Range
Dim iRow As Long
For iRow = LBound(DataValues) + 1 To UBound(DataValues) ' loop through all data and find blocks, collect them in even and odd numbered blocks for alternate coloring
If BlockValue <> DataValues(iRow, 1) Then
If iRow - iStart > 1 Then
Set CurrentBlock = DataRange.Cells(iStart, 1).Resize(RowSize:=iRow - iStart)
If IsEven Then
If EvenBlocks Is Nothing Then
Set EvenBlocks = CurrentBlock
Else
Set EvenBlocks = Union(EvenBlocks, CurrentBlock)
End If
Else
If OddBlocks Is Nothing Then
Set OddBlocks = CurrentBlock
Else
Set OddBlocks = Union(OddBlocks, CurrentBlock)
End If
End If
IsEven = Not IsEven
End If
iStart = iRow
BlockValue = DataValues(iRow, 1)
End If
Next iRow
' color all even and odd blocks alternating
EvenBlocks.Interior.Color = vbRed
OddBlocks.Interior.Color = vbGreen
End Sub
I managed to get this code:
Sub ColorChange()
Dim ws As Worksheet
Set ws = Worksheets(2)
clrOrange = 39423
clrWhite = RGB(255, 255, 255)
If ws.Range("D19").Value = "1" And ws.Range("E19").Value = "1" Then
ws.Range("D19", "E19").Interior.Color = clrOrange
ElseIf ws.Range("D19").Value = "0" Or ws.Range("E19").Value = "0" Then
ws.Range("D19", "E19").Interior.Color = clrWhite
End If
End Sub
This works, but now I need this code to work in 50 rows and 314 cells, but every time only on two cells so, D19+E19, D20+E20, etc. Endpoint is DB314+DC314.
Is there a way, without needing to copy paste this code and replacing all the row and cells by hand?
It also would be nice that if the value in the two cells is anything other than 1+1 the cell color changes back to white.
EDIT: The solution thanks to #VBasic2008.
I added the following to the sheet's code to get the solution to work automatically:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("D19:DC314")) Is Nothing Then
Call ColorChange
End If
End Sub
And because Interior.Color removes borders I added the following sub:
Sub vba_borders()
Dim iRange As Range
Dim iCells As Range
Set iRange = Range("D19:DC67,D70:DC86,D89:DC124,D127:DC176,D179:DC212,D215:DC252,D255:DC291,D294:DC314")
For Each iCells In iRange
iCells.BorderAround _
LineStyle:=xlContinuous, _
Weight:=xlThin
Next iCells
End Sub
The Range is a bit different to exclude some rows.
Compare Values in the Two Cells of Column Pairs
Option Explicit
Sub ColorChange()
Const rgAddress As String = "D19:DC314"
Const Orange As Long = 39423
Const White As Long = 16777215
Dim wb As Workbook ' (Source) Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
Dim rg As Range ' (Source) Range
Set rg = wb.Worksheets(2).Range(rgAddress) ' Rather use tab name ("Sheet2").
Dim cCount As Long ' Columns Count
cCount = rg.Columns.Count
Dim brg As Range ' Built Range
Dim rrg As Range ' Row Range
Dim crg As Range ' Two-Cell Range
Dim j As Long ' (Source)/Row Range Columns Counter
For Each rrg In rg.Rows
For j = 2 To cCount Step 2
Set crg = rrg.Cells(j - 1).Resize(, 2)
If crg.Cells(1).Value = 1 And crg.Cells(2).Value = 1 Then
If brg Is Nothing Then
Set brg = crg
Else
Set brg = Union(brg, crg)
End If
End If
Next j
Next rrg
Application.ScreenUpdating = False
rg.Interior.Color = White
If Not brg Is Nothing Then
brg.Interior.Color = Orange
End If
Application.ScreenUpdating = True
End Sub
I am trying to write a code for Excel in VBA which looks at a range of cells, in this example Range B4:B15, and first identifies which cells have a yellow fill color (interior color). Then of the cells colored yellow determine if any of those cells are blank.
If any of the yellow cells are blank, give a message for the entire range saying "there are yellow cells that are blank".
I'm using a For each rcell in r loop to determine which cells are yellow colored.
How do I build a new "sub-range" with only the cells colored yellow?
Sub Input_Checker_test()
Dim ws As Worksheet
Set ws = Sheets("Main")
Dim r As Range
Dim rcell As Range
Dim rmain As Range
Dim rmaincell As Range
Set r = Range("B4:B15").Cells
For Each rcell In r
If rcell.Interior.Color = 65535 Then
rcell = rmain
End If
Next rcell
For Each rmaincell In rmain
If WorksheetFunction.CountA(rmain) = 0 Then
MsgBox ("Cells are empty")
Else
MsgBox ("Cells are full")
End If
Next rmaincell
End Sub
I'm a little confused because you said font, then interior. If there is a yellow font, then there has to be a value, so I assumed you meant interior. Since you only need one of each to meet your criteria, you don't need to create a sub-range. You can test to see if any cells meet both criteria.
Sub Input_Checker_test()
Dim ws As Worksheet
Set ws = Sheets("Main")
Dim r As Range
Dim rcell As Range
Dim YellowCount as Integer
Dim EmptyCount as Integer
Set r = ws.Range("B4:B15")
For Each rcell In r
If rcell.Interior.Color = 65535 Then
YellowCount = 1
If IsEmpty(rcell) Then
EmptyCount = 1
End If
End If
Next rcell
If YellowCount > 0 Then
MsgBox "There are yellow cells"
End If
If EmptyCount > 0 Then
MsgBox "There are empty cells"
End If
End Sub