Conditional Format Shape Fill Based on Cell Value - excel

I hate to ask this question because I don't know where to start so I don't have any code right now. I've seen some stuff about the topic but can't find what I'm looking for.
Table is 5 column (ID + Bolt count) x 13 rows (ID)
I have four shapes (Oval4-Oval7) that I would like to change from red/orange/green based on four corresponding cells (options for those cell values are: empty, installed, torqued).
The shapes would also change color based on a chosen ID (1-13) in the first column.
So if you put your cursor on ID 2 cell, the shapes would change color based on the values in columns 2-5 from the same row.
Is this too overly complex?
I will continue to work on it myself. Just figured I would start here.
Thanks for your time.
Below code works but how do I apply it to the entire table?
Private Sub Worksheet_Change(ByVal Target As Range)
If Range("d12") = "Empty" Then
ActiveSheet.Shapes.Range(Array("Shape1")).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0)
Else
If Range("d12") = "Installed" Then
ActiveSheet.Shapes.Range(Array("Shape1")).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 155, 0)
Else
If Range("d12") = "Torqued" Then
ActiveSheet.Shapes.Range(Array("Shape1")).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 255, 0)
End If
End If
End If
End Sub

In the sheet code module:
Private Sub Worksheet_Change(ByVal Target As Range)
ResolveSelection Target.Cells(1)
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
ResolveSelection Target.Cells(1)
End Sub
'Is the selected/changed cell in one of the two tables?
' If Yes get the full row for that cell and pass to SetRow
Sub ResolveSelection(Target As Range)
Dim r, rng As Range
For Each r In Array("B3:G14", "J3:O14") 'my 2 test tables
Set rng = Application.Intersect(Target, Me.Range(r))
If Not rng Is Nothing Then
'get the whole row of the table
Set rng = Application.Intersect(Target.EntireRow, Me.Range(r))
SetRow rng
Exit Sub
End If
Next r
End Sub
'set the coloring based on the row 'rw'
Sub SetRow(rw As Range)
Dim i As Long, shp As Shape
Debug.Print rw.Address
For i = 1 To 4
Set shp = rw.Parent.Shapes("Shape" & i)
shp.Fill.ForeColor.RGB = GetColor(rw.Cells(2 + i).Value)
Next i
End Sub
'get the color for a given state
Function GetColor(v As String) As Long
Select Case v & ""
Case "Empty", "": GetColor = vbRed
Case "Installed": GetColor = RGB(255, 155, 0)
Case "Torqued": GetColor = vbGreen
Case Else: GetColor = vbWhite
End Select
End Function

Related

VBA code to autocolour text based on origin

I'm currently using this code to autocolour font based on its origin:
Sub Auto_Colour_Numbers()
Dim rng As Range, rErr As Range
On Error Resume Next
For Each rng In Intersect(ActiveSheet.UsedRange, Selection)
If rng.HasFormula Then
Set rErr = Range(Mid(rng.Formula, 2, Len(rng.Formula) - 1))
If CBool(Err) Then
rng.Font.ColorIndex = 1 'black
Else
rng.Font.Color = RGB(0, 176, 80) 'green
End If
Err = 0
ElseIf CBool(Len(rng.Value)) Then
rng.Font.ColorIndex = 5 'blue
Else
rng.Font.ColorIndex = xlAutomatic 'default
End If
Next rng
Set rErr = Nothing
End Sub
Basically it changes the font to blue if it's just a hard-coded number, black if it's a formula and green if it's coming from another worksheet
It works fairly well but there are a couple of problems:
1) If, for example, I have a number in cell A1 and then put the formula "=A1" in cell B1, the macro will turn the font green even though it's not being pulled from a separate worksheet
2) If I have a formula e.g. "=5+5" and then add onto that a cell linked from another sheet so that it become e.g. "=5+5+Sheet2!E8" it will still turn it black when ideally I'd like it to be green. I was thinking an if loop that looks for exclamation points might work for this?
Any help would be much appreciated (please assume no competence or knowledge of VBA in you answers as I am very much new to this!)
Thanks,
Thomas
CF is probably the way to go, but if you want a VBA solution try using the sheet change event so the code is run whenever you change a cell. Put the code in the sheet module (right-click the sheet tab, View Code, and paste the code).
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
For Each rng In Target
If rng.HasFormula Then
If InStr(rng.Formula, "!") Then
rng.Font.Color = RGB(0, 176, 80)
Else
rng.Font.ColorIndex = 1
End If
Else
rng.Font.ColorIndex = 5
End If
Next rng
End Sub
If you don't want it run automatically, just revert to a normal sub.
Sub x()
Dim rng As Range
For Each rng In Selection
If rng.HasFormula Then
If InStr(rng.Formula, "!") Then
rng.Font.Color = RGB(0, 176, 80)
Else
rng.Font.ColorIndex = 1
End If
Else
If Len(rng) > 0 Then rng.Font.ColorIndex = 5
End If
Next rng
End Sub
A third approach exploiting SpecialCells which minimises the amount of looping required.
Sub x()
Dim rng As Range, r1 As Range, r2 As Range
On Error Resume Next
Set r1 = Intersect(ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas), Selection)
Set r2 = Intersect(ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants, xlNumbers), Selection)
On Error GoTo 0
If Not r1 Is Nothing Then
For Each rng In r1
If InStr(rng.Formula, "!") Then
rng.Font.Color = RGB(0, 176, 80)
Else
rng.Font.ColorIndex = 1
End If
Next rng
End If
If Not r2 Is Nothing Then r2.Font.ColorIndex = 5
End Sub
Here's a no-VBA solution using conditional formatting.
To format the cells with a formula that points to another worksheet, create a format condition with the rule =IFERROR(FIND("!",FORMULATEXT(A1)),FALSE) (substituting the start of your actual data range for A1).
To format the hardcoded values, create another condition with rule =ISNA(FORMULATEXT(A1)).
The result of this is
where A1 is hardcoded, A2 is =A1 and A3 is =Sheet2!A1.
If you're using a version earlier than 2013 here's a solution that doesn't use FormulaText:
Public Function RefDifSheet(Target As Range) As Boolean
If Target.HasFormula Then
RefDifSheet = InStr(Target.Formula, "!") <> 0
Else
RefDifSheet = False
End If
End Function
Public Function IsFormula(Target As Range) As Boolean
IsFormula = Target.HasFormula
End Function
Then add three conditional format rules to your cell:
First rule: =RefDifSheet(A1)
Second rule: =IsFormula(A1)
Third rule: =ISNUMBER(A1)
I'm thinking it's probably also possible using Macro4 functions and named ranges - haven't looked into that yet. (GET.CELLS - using-excel-4-macro-functions)

Updating value of a non-Target cell in Excel VBA

I found the attached when looking for how to due an event change to correct user data based on the values in two columns. I'm not a programmer, so I may have butchered the code as I combined two different solutions together.
Right now, it's working exactly as I want it to. Changing the offset cell value forces Excel to replace the target value with what I've specified. What I'm looking to achieve (and am not sure is possible), is to reverse the code. Basically, I want to change the offset cell, if the values are entered in the opposite order. The code will change the cell value to "Beta" if a user enters "Bravo" in column A, and then "Gamma" in column C.
What I'm trying to achieve is that if the user enters "Bravo" in column A second, that Excel still sees the combination of these cells and still replaces the value with "Beta". I know this is additional code, but I couldn't find anything to support replacing cell when the target cell isn't the value being updated.
Thanks in advance!
Dim oldCellAddress As String
Dim oldCellValue As String
Private Sub Worksheet_Change(ByVal Target As Range)
oldCellValue = "Bravo"
If Target = "Bravo" And Target.Offset(0, -2) = "Gamma" Then
Target.Value = "Beta"
Application.EnableEvents = True
End If
End Sub
This may meet your needs:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim colnum As Long, v As Variant
colnum = Target.Column
v = Target.Value
If colnum = 1 Then
If v = "Bravo" And Target.Offset(0, 2) = "Gamma" Then
Application.EnableEvents = False
Target.Value = "Beta"
Application.EnableEvents = True
End If
Exit Sub
End If
If colnum = 3 And v = "Gamma" And Target.Offset(0, -2) = "Bravo" Then
Application.EnableEvents = False
Target.Offset(0, -2).Value = "Beta"
Application.EnableEvents = True
End If
End Sub
For example if the user puts Bravo in cell A1 and C1 already contained Gamma, the code puts Beta in A1 (the code corrects the A1 entry).If the user puts Gamma in cell C1 and cell A1 already contained Bravo, the code corrects A1.
There are two possible scenarios like below...
Scenario 1:
If ANY CELL on the sheet is changed, the following code will check the content of column A and C in the corresponding row and change the content of the Target Cell.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
Dim r As Long
r = Target.Row
On Error GoTo Skip:
Application.EnableEvents = False
If Cells(r, "A") = "Bravo" And Cells(r, "C") = "Gamma" Then
Target.Value = "Beta"
End If
Skip:
Application.EnableEvents = True
End Sub
Scenario 1:
If a cell in column D is changed, the change event will be triggered and check the content in column A and C in the corresponding row and change the Target Cell in Column D.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
Dim r As Long
On Error GoTo Skip:
'The below line ensures that the sheet change event will be triggered when a cell in colunm D is changed
'Change it as per your requirement.
If Not Intersect(Target, Range("D:D")) Is Nothing Then
Application.EnableEvents = False
r = Target.Row
If Cells(r, "A") = "Bravo" And Cells(r, "C") = "Gamma" Then
Target.Value = "Beta"
End If
End If
Skip:
Application.EnableEvents = True
End Sub

Go to first empty cell after selected cell

I am trying to implement a code, where if you click a certain cell; you go to the first empty cell in a certain column.
Now I have this code:
If Selection.Count = 1 Then
If Not Intersect(Target, Range("B2")) Is Nothing Then
Columns("E").Find(vbNullString, Cells(Rows.Count, "E")).Select
End If
End If
But there is a problem with this code: I want it to start checking the first empty cell; starting at row 3. How do I do this?
Edit1:
I have made some adjustments to the code to fit my needs (for practice and aesthetics);
Dim lastCell As Range
Set lastCell = Range("E:E").Find(vbNullString, [E3], , , , xlNext)
lastCell.Interior.Color = RGB(100, 200, 100)
lastCell.Offset(0, -3) = "Last Cell -->"
lastCell.Offset(0, -3).Interior.Color = RGB(0, 110, 250)
lastCell.Offset(0, -3).Font.Color = vbWhite
If Not Intersect(Target, [B2]) Is Nothing Then
lastCell.Select
Side Note
The reason for Offset three columns to the right is because of the lay-out of the sheet :)
I clear the formatting of the cell and the text somewhere else if lastCell is changed. So if anyone is interested, let me know.
You can re-write your code like this, just by supplying SearchDirection argument.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Selection.Count = 1 Then
If Not Intersect(Target, Range("B2")) Is Nothing Then
Columns("E").Find(vbNullString, Cells(Rows.Count, "E") _
, , , , xlPrevious).Select
End If
End If
End Sub
Or you can try this one:
Edit1: For brettdj :)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Goto errhandler
Application.EnableEvents = False
If Target.Cells.Count = 1 Then
If Not Intersect(Target, [B2]) Is Nothing Then _
Range("E:E").Find(vbNullString, [E3], , , , xlNext).Select
End If
continue:
Application.EnableEvents = True
Exit Sub
errhandler:
MsgBox Err.Description
Resume continue
End Sub
Both code works the same way except if there are blank cells in between E3:E(x).
Your revise code finds the first empty cell in Column E with reference to the last non empty cell.
The next code literally finds the first empty cell from E3. Don't know which is really what you need.
Side Notes:
Columns("E") is the same as Range("E:E").
Why use Range("E:E") then? Well, Intellisense kicks in with Range and not with Columns.
So I prefer using Range so you can see all the available arguments of .Find method.
This is what I would do:
Dim maxrows&, iRow&, iCol&, zcell As Range
maxrows = Excel.Rows.Count
If Selection.Count = 1 Then
iRow = Target.Row
iCol = Target.Column
Set zcell = Range(Cells(3, iCol), Cells(maxrows, iCol)).Find(vbNullString)
zcell.Select
End If

Excel : Alternatively Change Cell Color as Cell Value Changes

I have developed an Excel Real-Time Data Feed (RTD) to monitor Stock Prices as they arrive.
I Would like to find a way to change the color of a cell as prices change.
For example, a cell initially Green would turn to Red when the value changes (new price occurred on it via RTD Formula it contains) and then change back to Green when a new price arrives, and so on...
Maybe this can get you started?
I supose a event is raised when the real time data is refreshed.
the concept sis to store the real time data in a variabele and check if it has changed
Dim rtd As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With ActiveSheet.Range("A1")
If .Value <> rtd Then
Select Case .Interior.ColorIndex
Case 2
.Interior.ColorIndex = 3
Case 3
.Interior.ColorIndex = 4
Case 4
.Interior.ColorIndex = 3
Case Else
.Interior.ColorIndex = 2
End Select
Else
.Interior.ColorIndex = 2
End If
rtd = .Value
End With
End Sub
Sub Worksheet_Change(ByVal ChangedCell As Range)
' This routine is called whenever the user changes a cell.
' It is not called if a cell is changed by Calculate.
Dim ColChanged As Integer
Dim RowChanged As Integer
ColChanged = ChangedCell.Column
RowChanged = ChangedCell.Row
With ActiveSheet
If .Cells(RowChanged, ColChanged).Interior.ColorIndex = 19 Then
' Changed cell is red. Set it to green.
.Cells(RowChanged, ColChanged).Interior.ColorIndex = 19
Else
' Changed cell is not red. Set it to red.
.Cells(RowChanged, ColChanged).Interior.ColorIndex = 19
End If
End With
End Sub
This solution reposonds to a Calculation event. I am not entirely sure if an RTD update triggers this, so you will need to experiment.
Add this code to the Worksheet module containing your RTD calls.
It keeps a copy of the sheet data in memory from the last calculation, and on each calc compares new values.
It limits its action to cells containing your formula.
Option Explicit
Dim vData As Variant
Dim vForm As Variant
Private Sub Worksheet_Calculate()
Dim vNewData As Variant
Dim vNewForm As Variant
Dim i As Long, j As Long
If IsArray(vData) Then
vNewData = Me.UsedRange
vNewForm = Me.UsedRange.Formula
For i = LBound(vData, 1) To UBound(vData, 1)
For j = LBound(vData, 2) To UBound(vData, 2)
' Change this to match your RTD function name
If vForm(i, j) Like "=YourRTDFunction(*" Then
If vData(i, j) <> vNewData(i, j) Then
With Me.Cells(i, j).Interior
If .ColorIndex = 3 Then
.ColorIndex = 4
Else
.ColorIndex = 3
End If
End With
End If
End If
Next j, i
End If
vData = Me.UsedRange
vForm = Me.UsedRange.Formula
End Sub
Both the previous answer assume that Real-time data feed triggers worksheet events. I can find nothing in the RTD documents to confirm or deny this assumption. However, if it does trigger worksheet events, I would have thought that Worksheet_Change would have been the most useful since it identifies a cell that has changed.
The following might be worth trying. It must be placed in the code area for the relevant worksheet.
Option Explicit
Sub Worksheet_Change(ByVal ChangedCell As Range)
' This routine is called whenever the user changes a cell.
' It is not called if a cell is changed by Calculate.
Dim ColChanged As Integer
Dim RowChanged As Integer
ColChanged = ChangedCell.Column
RowChanged = ChangedCell.Row
With ActiveSheet
If .Cells(RowChanged, ColChanged).Font.Color = RGB(255, 0, 0) then
' Changed cell is red. Set it to green.
.Cells(RowChanged, ColChanged).Font.Color = RGB(0, 255, 0)
Else
' Changed cell is not red. Set it to red.
.Cells(RowChanged, ColChanged).Font.Color = RGB(255, 0, 0)
End If
End With
End Sub
I was looking for same. My scenario was like change the color of cell when value is select from list. Each list item corresponds for a color.
What eventually worked for me is:
Private Sub Worksheet_Change(ByVal Target As Range)
Set MyPlage = Range("B2:M50")
For Each Cell In MyPlage
Select Case Cell.Value
Case Is = "Applicable-Incorporated"
Cell.Font.Color = RGB(0, 128, 0)
Case Is = "Applicable/Not Incorporated"
Cell.Font.Color = RGB(255, 204, 0)
Case Is = "Not Applicable"
Cell.Font.Color = RGB(0, 128, 0)
Case Else
Cell.EntireRow.Interior.ColorIndex = xlNone
End Select
Next
ActiveWorkbook.Save
End Sub
Alternatively, the most simple is this code :
Private Sub Worksheet_Change(ByVal Target As Range)
Target.Interior.ColorIndex = 6 ': yellow
End Sub

How can I run VBA code each time a cell gets its value changed by a formula?

How can I run a VBA function each time a cell gets its value changed by a formula?
I've managed to run code when a cell gets its value changed by the user, but it doesn't work when the value is changed due to a formula referencing another cell.
If I have a formula in cell A1 (e.g. = B1 * C1) and I want to run some VBA code each time A1 changes due to updates to either cell B1 or C1 then I can use the following:
Private Sub Worksheet_Calculate()
Dim target As Range
Set target = Range("A1")
If Not Intersect(target, Range("A1")) Is Nothing Then
//Run my VBA code
End If
End Sub
Update
As far as I know the problem with Worksheet_Calculate is that it fires for all cells containing formulae on the spreadsheet and you cannot determine which cell has been re-calculated (i.e. Worksheet_Calculate does not provide a Target object)
To get around this, if you have a bunch of formulas in column A and you want to identify which one has updated and add a comment to that specific cell then I think the following code will achieve that:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim updatedCell As Range
Set updatedCell = Range(Target.Dependents.Address)
If Not Intersect(updatedCell, Range("A:A")) Is Nothing Then
updatedCell.AddComment ("My Comments")
End If
End Sub
To explain, for a formula to update, one of the input cells into that formula must change e.g. if formula in A1 is =B1 * C1 then either B1 or C1 must change to update A1.
We can use the Worksheet_Change event to detect a cell change on the s/sheet and then use Excel's auditing functionality to trace the dependents e.g. cell A1 is dependent on both B1 and C1 and, in this instance, the code Target.Dependents.Address would return $A$1 for any change to B1 or C1.
Given this, all we now need to do is to check if the dependent address is in column A (using Intersect). If it is in Column A we can then add comments to the appropriate cell.
Note that this only works for adding comments once only into a cell. If you want to continue to overwrite comments in the same cell you would need to modify the code to check for the existance of comments first and then delete as required.
The code you used does not work because the cell changing is not the cell with the formula but the cell... being changed :)
Here is what you should add to the worksheet's module:
(Updated: The line "Set rDependents = Target.Dependents" will raise an Error if there are no dependents. This update takes care of this.)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rDependents As Range
On Error Resume Next
Set rDependents = Target.Dependents
If Err.Number > 0 Then
Exit Sub
End If
' If the cell with the formula is "F160", for example...
If Not Application.Intersect(rDependents, Range("F160")) Is Nothing Then
Call abc
End If
End Sub
Private Sub abc()
MsgBox """abc()"" is running now"
End Sub
You can expand this if there are many dependent cells by setting up an array of cell addresses in question. Then you would test for each address in the array (you can use any looping structure for this) and run a desired subroutine corresponding to the changed cell (use SELECT CASE...) for this.
Here is another way using classes. The class can store cell Initial value and cell address. On calculate event it will compare the address current value with the stored initial value. Example below is made to listen to one cell only ("A2"), but you can initiate listening to more cells in the module or change the class to work with wider ranges.
Class module called "Class1":
Public WithEvents MySheet As Worksheet
Public MyRange As Range
Public MyIniVal As Variant
Public Sub Initialize_MySheet(Sh As Worksheet, Ran As Range)
Set MySheet = Sh
Set MyRange = Ran
MyIniVal = Ran.Value
End Sub
Private Sub MySheet_Calculate()
If MyRange.Value <> MyIniVal Then
Debug.Print MyRange.Address & " was changed from " & MyIniVal & " to " & MyRange.Value
StartClass
End If
End Sub
Initialize the class in normall module.
Dim MyClass As Class1
Sub StartClass()
Set MyClass = Nothing
Set MyClass = New Class1
MyClass.Initialize_MySheet ActiveSheet, Range("A2")
End Sub
Here is my code:
I know it looks terrible, but it works!
Of course there are solutions which are much better.
Description of the code:
When the Workbook opens, the value of the cells B15 till N15 are saved in the variable PrevValb till PrevValn. If a Worksheet_Calculate() event occurs, the previous values are compared with the actual values of the cells. If there is a change of the value, the cell is marked with red color. This code could be written with functions, so that he is much shorter and easier to read.
There's a color-reset-button (Seenchanges), which resets the color to the previous color.
Workbook:
Private Sub Workbook_Open()
PrevValb = Tabelle1.Range("B15").Value
PrevValc = Tabelle1.Range("C15").Value
PrevVald = Tabelle1.Range("D15").Value
PrevVale = Tabelle1.Range("E15").Value
PrevValf = Tabelle1.Range("F15").Value
PrevValg = Tabelle1.Range("G15").Value
PrevValh = Tabelle1.Range("H15").Value
PrevVali = Tabelle1.Range("I15").Value
PrevValj = Tabelle1.Range("J15").Value
PrevValk = Tabelle1.Range("K15").Value
PrevVall = Tabelle1.Range("L15").Value
PrevValm = Tabelle1.Range("M15").Value
PrevValn = Tabelle1.Range("N15").Value
End Sub
Modul:
Sub Seenchanges_Klicken()
Range("B15:N15").Interior.Color = RGB(252, 213, 180)
End Sub
Sheet1:
Private Sub Worksheet_Calculate()
If Range("B15").Value <> PrevValb Then
Range("B15").Interior.Color = RGB(255, 0, 0)
PrevValb = Range("B15").Value
End If
If Range("C15").Value <> PrevValc Then
Range("C15").Interior.Color = RGB(255, 0, 0)
PrevValc = Range("C15").Value
End If
If Range("D15").Value <> PrevVald Then
Range("D15").Interior.Color = RGB(255, 0, 0)
PrevVald = Range("D15").Value
End If
If Range("E15").Value <> PrevVale Then
Range("E15").Interior.Color = RGB(255, 0, 0)
PrevVale = Range("E15").Value
End If
If Range("F15").Value <> PrevValf Then
Range("F15").Interior.Color = RGB(255, 0, 0)
PrevValf = Range("F15").Value
End If
If Range("G15").Value <> PrevValg Then
Range("G15").Interior.Color = RGB(255, 0, 0)
PrevValg = Range("G15").Value
End If
If Range("H15").Value <> PrevValh Then
Range("H15").Interior.Color = RGB(255, 0, 0)
PrevValh = Range("H15").Value
End If
If Range("I15").Value <> PrevVali Then
Range("I15").Interior.Color = RGB(255, 0, 0)
PrevVali = Range("I15").Value
End If
If Range("J15").Value <> PrevValj Then
Range("J15").Interior.Color = RGB(255, 0, 0)
PrevValj = Range("J15").Value
End If
If Range("K15").Value <> PrevValk Then
Range("K15").Interior.Color = RGB(255, 0, 0)
PrevValk = Range("K15").Value
End If
If Range("L15").Value <> PrevVall Then
Range("L15").Interior.Color = RGB(255, 0, 0)
PrevVall = Range("L15").Value
End If
If Range("M15").Value <> PrevValm Then
Range("M15").Interior.Color = RGB(255, 0, 0)
PrevValm = Range("M15").Value
End If
If Range("N15").Value <> PrevValn Then
Range("N15").Interior.Color = RGB(255, 0, 0)
PrevValn = Range("N15").Value
End If
End Sub

Resources