So every cell that has a value of 0, that row will be hidden. And any value that is outside the minimum and maximum values will be red.
How to identify red color but active (not hidden) with macro? because I used "range. displayformat. interior. color = vbred", the cells are red but hidden are also counted. Thanks.
Try this, the visible cells will be formatted
Set rng = Range("Your range").SpecialCells(xlCellTypeVisible)
rng = ActiveCell.DisplayFormat.Interior.Color = vbRed
Here is the sample code for the "if" condition that you ask for.
Sub Highlight_Greater_Than()
Dim ws As Worksheet
Dim Rng As Range
Dim ColorCell As Range
Set ws = Worksheets("Name")
Set rng = Range("Your range").SpecialCells(xlCellTypeVisible)
'rng = ActiveCell.DisplayFormat.Interior.Color = vbRed
Set ColorCell = rng
For Each ColorCell In Rng
If ColorCell.Value > 1 Then " You can define here" "greater, smaller, equal etc.."
ColorCell.Interior.Color = vbred
Else
ColorCell.Interior.ColorIndex = "vb(colour)or" xlNone
End If
Next
End Sub
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
I have written a short Macro to change cells of a given colour to another colour in a workbook. This code throws no errors however it simply does nothing.
I have already tested the colour codes to see if they are correct using MsgBox ActiveCell.DisplayFormat.Interior.color
Option Explicit
Sub Recolour()
Application.ScreenUpdating = False
Dim Sheet As Worksheet
Dim Rng As Range
Dim OldColour As Variant
Dim NewColour As Variant
Dim Cell As Range
Set Rng = ActiveSheet.Range("A1:Y457")
OldColour = 128
NewColour = RGB(134, 38, 51)
For Each Sheet In ThisWorkbook.Worksheets
For Each Cell In Rng.Cells
If ActiveCell.DisplayFormat.Interior.Color = OldColour _
Then _
Set ActiveCell.DisplayFormat.Interior.Color = NewColour _
Else
Next Cell
Next Sheet
Application.ScreenUpdating = True
End Sub
This is probably something simple and daft however I need to ask.
DisplayFormat is read-only. If you want to change the property, you need to drop DisplayFormat. Also, if you are using For each Cell, then you should refer to Cell, not ActiveCell.
For Each Sheet In ThisWorkbook.Worksheets
For Each Cell In Rng.Cells
If Cell.Interior.color = OldColour Then
Cell.Interior.color = NewColour
End if
Next Cell
Next Sheet
You only need to Set object variables in VBA, your if statement is also problematic. Try:
For Each Sheet In ThisWorkbook.Worksheets
For Each Cell In Rng.Cells
If ActiveCell.DisplayFormat.Interior.color = OldColour Then
ActiveCell.DisplayFormat.Interior.color = NewColour
End if
Next Cell
Next Sheet
I have a range of values, I want to find the MIN, then highlight the row of this Min value.
Sub worstcase()
Set Rng = .Range("H44:H54")
worstcase = Application.WorksheetFunction.Min(Rng)
Debug.Print worstcase
How can I highlight rows based on variable worstcase?
I have my static range, and find the min value, but now I need to highlight the row of the worstcase variable.
Highlight Row With Found Criteria
The code is highlighting each row where the minimum was found. Use Exit For to highlight only the first found.
The Code
Sub worstcase()
Dim worstcase As Double ' Long for whole numbers.
Dim rng As Range
Dim cell As Range
With Worksheets("Sheet1")
Set rng = .Range("H44:H54")
worstcase = Application.WorksheetFunction.Min(rng)
Debug.Print worstcase
For Each cell In rng
If cell.Value = worstcase Then
cell.EntireRow.Interior.ColorIndex = 3 ' Hightlight whole row.
'cell.Interior.ColorIndex = 5 ' Hightlight only cell.
'Exit For ' To highlight only the first found row.
End If
Next
End With
End Sub
EDIT:
Sub worstcase()
Const cFirst As Variant = "H"
Const cLast As Variant = "Q"
Dim worstcase As Double ' Long for whole numbers.
Dim rng As Range
Dim cell As Range
With Worksheets("Sheet1")
Set rng = .Range("H44:H54")
worstcase = Application.WorksheetFunction.Min(rng)
Debug.Print worstcase
For Each cell In rng
If cell.Value = worstcase Then
.Range(.Cells(cell.Row, cFirst), .Cells(cell.Row, cLast)) _
.Interior.ColorIndex = 3 ' Hightlight cells.
'Exit For ' To highlight only the first found cells.
End If
Next
End With
End Sub
You could do it thus.
Won't work though if you have a repeated minimum.
Also you could use conditional formatting and avoid VBA.
Sub worstcase()
Dim Rng As Range, worstcase, i As Long
Set Rng = Range("H44:H54")
With Rng
worstcase = Application.WorksheetFunction.Min(.Cells)
i = Application.Match(worstcase, .Cells, 0)
.Cells(i).EntireRow.Interior.Color = vbRed
End With
End Sub
Create a conditional formatting rule based on the following formula.
=$H44=min($H$44:$H$54)
This VBA will create a CFR for rows 44:54.
With worksheets("sheet1").range("44:54")
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=$H44=min($H$44:$H$54)"
.FormatConditions(.FormatConditions.Count).Interior.Color = vbred
End With
I have attached screenshot to visualize what I am trying to do.
I am trying to replace the fill colors of cells in a column "Yesterday" based on the existing cell fill color.
I have seen examples of replacing colors based of a value in a cell but I think I have a different scenario.
maybe this can help you:
Option Explicit
Public Sub main()
Dim cell As Range, foundCells As Range
Dim yesterdayColor As Long, todayColor As Long
yesterdayColor = Range("H3").Interior.Color
todayColor = Range("H4").Interior.Color
With Range("B5:B17") '<--| reference wanted range of which coloring any "yesterdayColor" colored cells with "todayColor" color
Set foundCells = .Offset(, .Columns.Count).Resize(1, 1) '<-- initialize a dummy "found" cell outside the relevant range and avoid 'IF' checking in subsequent 'Union()' method calls
For Each cell In .Cells '<--| loop through referenced range cells
If cell.Interior.Color = yesterdayColor Then Set foundCells = Union(foundCells, cell) '<--| gather yesterday colored cells together
Next cell
Set foundCells = Intersect(.Cells, foundCells) '<--| get rid of the dummy "found" cell
End With
If Not foundCells Is Nothing Then foundCells.Interior.Color = todayColor '<--| if any cell has been found then change their color
End Sub
Edit: Try this.
Public Sub ChangeCellColors()
Dim rngTarget As Excel.Range: Set rngTarget = Range("H3")
Dim rngSource As Excel.Range: Set rngSource = Range("H4")
Dim rngCell As Excel.Range
For Each rngCell In Range("B4:B17")
With rngCell.Interior
If rngCell.Interior.Color = rngTarget.Interior.Color Then
.Pattern = rngSource.Interior.Pattern
.PatternColorIndex = rngSource.Interior.PatternColorIndex
.Color = rngSource.Interior.Color
.TintAndShade = rngSource.Interior.TintAndShade
.PatternTintAndShade = rngSource.Interior.PatternTintAndShade
End If
End With
Next rngCell
Set rngSource = Nothing
Set rngTarget = Nothing
Set rngCell = Nothing
End Sub