Excel VBA Help: Color Code Based on Single Direct Precedent

Question

Hi there,

I do a lot of financial modeling in Excel, and my firm color codes single direct precedents green (RGB 0,128,0). I'm looking for a string of code that can recognize and color cells of this kind automatically. Below outlines the parameters by way of illustration.

Please let me know if I've made the parameters clear. Note that anchoring the cells should not impact what the code does, if working properly. Any help is appreciated!

Answer 1

re: another try

You can test if for me...

Sub ColorFormulaPrecedentsR1()
' Colors worksheet formula precedents on the active sheet.
' Nothing Left to Lose - Portland, Oregon - August 2021
On Error GoTo ErrFindingFormulas
Application.EnableCancelKey = xlErrorHandler
Dim FormulaRange As Excel.Range, FormulaArea As Excel.Range
Dim objGeneric As Excel.Range, objCell As Excel.Range, objCell2 As Excel.Range
Dim FormulaCell As Excel.Range, objWS As Excel.Worksheet, strTest As String
Dim N As Long, AreaCnt As Long, lngC As Long, blnFound As Boolean

Set objWS = ActiveSheet
Application.Cursor = xlWait
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

On Error Resume Next
Set FormulaRange = objWS.Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo ErrFindingFormulas
If Not FormulaRange Is Nothing Then
blnFound = True

AreaCnt = FormulaRange.Areas.Count 'Edited by moving this line here.
For Each FormulaArea In FormulaRange.Areas
DoEvents
N = N + 1
Application.StatusBar = "MAPPING SHEET... " & objWS.Name & _
VBA.Format(N / AreaCnt, " #00%")
For Each FormulaCell In FormulaArea.Cells
'Value returns an error, Formula does not.
If VBA.Len(FormulaCell.Formula) Then
On Error Resume Next
Set objGeneric = FormulaCell.Precedents
On Error GoTo ErrFindingFormulas

 If Not objGeneric Is Nothing Then  
   If VBA.IsNull(objGeneric.MergeCells) Or objGeneric.MergeCells Then  
   VBA.MsgBox objGeneric.Address(False, False) & " is merged. ", \_  
       vbInformation, "Color Formula Precedents"  
   GoTo Exit\_FindFormulas  
   End If  
 strTest = FormulaCell.Formula  
 strTest = VBA.Mid(strTest, 2, 999)  
 If VBA.Left(strTest, 1) = VBA.Chr$(45) Then strTest = VBA.Mid(strTest, 2, 999)  
 On Error Resume Next  
 Set objCell2 = objWS.Range(strTest)  
 On Error GoTo ErrFindingFormulas  
 If Not objCell2 Is Nothing Then  
   FormulaCell.Font.Color = RGB(0, 128, 0)  
 End If  
 End If  

End If
Set objGeneric = Nothing
Set objCell2 = Nothing
Next
Next
End If

Application.ScreenUpdating = True
Application.Cursor = xlDefault
If blnFound = False Then
VBA.MsgBox "No formulas were found. ", vbInformation, "Color Formula Precedents"
Else 'If lngC > 1 Then
VBA.MsgBox lngC & " Precedents were found. ", vbInformation, "Color Formula Precedents"
End If

Exit_FindFormulas:
On Error Resume Next
Set objWS = Nothing
Set objCell = Nothing
Set objCell2 = Nothing
Set objGeneric = Nothing
Set FormulaCell = Nothing
Set FormulaArea = Nothing
Set FormulaRange = Nothing
Application.StatusBar = False
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.Cursor = xlDefault
Exit Sub

ErrFindingFormulas:
Beep
Application.ScreenUpdating = True
Application.Cursor = xlDefault
VBA.MsgBox "Error " & Err.Number & " - " _
& Err.Description & " ", vbCritical, "Color Formula Precedents "
Resume Exit_FindFormulas
End Sub
'---

NLtL

Answer 2

re: sample workbook

I had assumed you could put the workbook up on your OneDrive

and provide the link.

Before going further, as far as my memory serves, VBA can only

locate precedents that are on the same worksheet as the formula.
Will that be a problem?

NLtL

Answer 3

I'm having trouble uploading it to the link you sent, but the test is as simple as what I set up in the screenshot above.

Answer 4

Re: identify direct precedents

Do you have a sample (non-confidential) workbook available for testing purposes?
I have an old vba program that might? be updated to do what you want.

You could stick the file on OneDrive for download.

'---
NLtL

https://1drv.ms/u/s!Au8Lyt79SOuhZw2MCH7_7MuLj04?e=sAwbHU

(free excel programs)