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
Related
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
I am writing a check in/out program in excel and have gotten te request that if a line contains "|0|" it should get a different font color.
I've tried with Instr and Cells().Characters but I cannot seem to figure out how to do it.
The cells can have a variety of rows of text. Which is easy enough to solve with splitting them on a return and having a for loop loop, but I cannot seem to figure out how to assign a different font color to a row of text that contains the required value.
Image for illustration of the data:
How do I best solve this?
Added information:
The goal of this is that on button press the whole line of text where the |O| is would be collored differently. Other lines of text that do not have this will remain the same color.
Like in this image as a concept
[]
try this
Public Sub ExampleMainSub()
Dim cell As Range
For Each cell In Selection
If HasMySymbols(cell.Value) Then
WorkWithCellContent cell
Else
cell.Font.ColorIndex = xlAutomatic
cell.Font.TintAndShade = 0
End If
Next cell
End Sub
Private Sub WorkWithCellContent(ByVal cell As Range)
Dim arr As Variant
arr = Split(cell.Value, Chr(10))
Dim firstPosOfRow As Long
firstPosOfRow = 1
Dim subLine As Variant
For Each subLine In arr
If HasMySymbols(subLine) Then
cell.Characters(start:=firstPosOfRow, Length:=Len(subLine)).Font.Color = vbRed
Else
cell.Characters(start:=firstPosOfRow, Length:=Len(subLine)).Font.ColorIndex = xlAutomatic
End If
firstPosOfRow = firstPosOfRow + Len(subLine) + 1 '+1 is needed
Next subLine
End Sub
Private Function HasMySymbols(ByVal somestring As String) As Boolean
HasMySymbols = InStr(1, somestring, "|0|") > 0
End Function
Try this. It works for me.
Sub ChangeRowFontColour()
Dim rng As Range
Dim TextToFind As String
Dim FirstFound As String
TextToFind = "Specific Text"
With ActiveSheet.UsedRange
Set rng = .Cells.Find(TextToFind, LookIn:=xlValues)
If Not rng Is Nothing Then
FirstFound = rng.Address
Do
rng.EntireRow.Font.ColorIndex = 3
For Each part In rng
lenOfPart = Len(part)
lenTextToFind = Len(TextToFind)
For i = 1 To lenOfPart
tempStr = Mid(part, i, lenTextToFind)
If tempStr = TextToFind Then
part.Characters(Start:=i, Length:=lenTextToFind).Font.ColorIndex = 0
End If
Next i
Next
Set rng = .FindNext(rng)
Loop While Not rng Is Nothing And rng.Address <> FirstFound
End If
End With
End Sub
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 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