VBA code to autocolour text based on origin - excel

Question

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

Answer 1

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

Answer 2

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.

Answer 3

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)