Const debugMode As Boolean = True
Public Sub ColorReferences()
Dim rngSource As Excel.Range
Dim rngTarget As Excel.Range
Dim rng As Excel.Range
Dim v As Variant
Dim iColor() As Long
Dim i As Long, j As Long, k As Long
Dim ColorCycle As Variant
ColorCycle = Array(3, 4, 5, 7, 9, 10, 12, 13, 14, 18, 29, 38, 43, 44, 46, 48)
On Error Resume Next
Set rngSource = Application.InputBox( _
Prompt:="Select source cell:", _
Type:=8)
If rngSource Is Nothing Then Exit Sub
Set rngTarget = Application.InputBox( _
Prompt:="Select target cell:", _
Type:=8)
If rngTarget Is Nothing Then Exit Sub
On Error GoTo 0
v = extractAddress(rngSource, False)
' set colors
ReDim iColor(1 To UBound(v, 2))
k = 0
For i = 1 To UBound(v, 2)
If i > 1 Then
For j = 1 To i - 1
If StrComp(v(1, i), v(1, j)) = 0 Then
iColor(i) = iColor(j)
Exit For
End If
Next j
End If
If iColor(i) = 0 Then
If k > UBound(ColorCycle) Then
k = 1
Else
k = k + 1
End If
iColor(i) = ColorCycle(k - 1)
End If
Next i
rngTarget.Value = "'" & rngSource.Formula
For i = 1 To UBound(v, 2)
Set rng = rngSource.Parent.Range(v(1, i))
For j = XlBordersIndex.xlEdgeLeft To XlBordersIndex.xlEdgeRight
With rng.Borders(j)
.Weight = XlBorderWeight.xlMedium
.ColorIndex = iColor(i)
End With
Next j
rngTarget.Characters(v(2, i) + 1, v(3, i)).Font.ColorIndex = iColor(i)
Next i
' rngTarget.Offset(1, 0).Resize(3, UBound(v, 2)).Value = v
End Sub
Private Function extractAddress(ByVal rng As Excel.Range, _
Optional extraParens As Boolean = False) As Variant()
Const iIncr As Long = 10
Dim iPos As Long, iSize As Long
Dim retVal() As Variant
Const maxAddressLength As Integer = 12
Dim inQuotes As Boolean, isRange As Boolean
Dim parseString As String, tempString As String
Dim addressLength As Long, parsePosition As Long
Dim rangeLength As Long
Dim cursor As Long
Dim returnValue As String
Dim formulaString As String
If Not rng.HasFormula Then Exit Function
formulaString = VBA.Right$(rng.Formula, VBA.Len(rng.Formula) - 1) & "~"
If debugMode Then
Debug.Print rng.Address & " has a formula: " & rng.Formula
End If
If Not hasReference(rng) Then Exit Function
iPos = 0
iSize = iIncr
ReDim retVal(1 To 3, 1 To iSize)
For cursor = 1 To VBA.Len(formulaString)
parseString = VBA.Mid$(formulaString, cursor, maxAddressLength)
If (VBA.Left$(parseString, 1) = VBA.Chr(34)) Then
inQuotes = Not inQuotes
End If
If Not inQuotes Then
isRange = False
addressLength = 0
For parsePosition = 2 To _
Application.WorksheetFunction.Max(maxAddressLength, VBA.Len(formulaString) - cursor + 1)
If isAddress(VBA.Left$(parseString, parsePosition)) Then
addressLength = parsePosition
ElseIf (addressLength <> 0) Then
isRange = True
Exit For
End If
Next parsePosition
If isRange Then
If VBA.Mid$(parseString, addressLength + 1, 1) = ":" Then
'we have a range on our hands
parseString = VBA.Mid$(formulaString, cursor, maxAddressLength * 2 + 1)
If debugMode Then
Debug.Print "Processing range in " & parseString
End If
For parsePosition = 2 To maxAddressLength
If isAddress(VBA.Mid$(parseString, addressLength + 2, parsePosition)) Then
rangeLength = addressLength + parsePosition + 2
End If
Next parsePosition
addressLength = rangeLength - 1
End If
iPos = iPos + 1
If iPos > iSize Then
iSize = iSize + iIncr
ReDim Preserve retVal(1 To 3, 1 To iSize)
End If
retVal(1, iPos) = VBA.Left$(parseString, addressLength)
retVal(2, iPos) = cursor
retVal(3, iPos) = addressLength
cursor = cursor + addressLength - 1
End If
End If
Next cursor
If iPos < iSize Then
iSize = iPos
ReDim Preserve retVal(1 To 3, 1 To iSize)
End If
extractAddress = retVal
End Function
Private Function hasReference(ByVal rng As Range) _
As Boolean
If Not rng.HasFormula Then Exit Function
If isAddress(rng.Formula, False) Then
hasReference = True
End If
End Function
Private Function isAddress(strTest As String, _
Optional wholestring As Boolean = True) _
As Boolean
Dim re As Object
Dim strPattern As String
Set re = CreateObject("VBScript.RegExp")
If (wholestring) Then strPattern = "^"
strPattern = strPattern & _
"[\$]{0,1}[A-Z]{1,3}[\$]{0,1}[1-9][0-9]{0,6}"
If (wholestring) Then strPattern = strPattern & "$"
re.Pattern = strPattern
re.IgnoreCase = True
isAddress = re.test(strTest)
End Function
