Public Const strSourceSht = "Trial Balance"
Public Const strKeySht = "BS Movement"
Sub Main()
Dim ws As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim i As Long
Set ws = ThisWorkbook.Sheets(strSourceSht)
Set rng1 = ws.Range(ws.[a2], ws.Cells(Rows.Count, "A").End(xlUp))
If rng1 Is Nothing Then Exit Sub
rng1.EntireColumn.Interior.ColorIndex = xlNone
Application.ScreenUpdating = False
For Each rng2 In rng1
If Len(rng2.Value) > 0 Then
rng2.NumberFormat = "@"
If CellUsedinFormula(Trim(rng2.Value)) Then
Else
i = i + 1
rng2.Interior.Color = vbRed
End If
End If
Next
For Each ws In ActiveWorkbook.Worksheets
ws.ClearArrows
Next ws
Application.Goto rng1.Cells(1)
Application.ScreenUpdating = True
If i > 0 Then MsgBox i & " cells were found that are not used" & vbNewLine & "these have been coloured red"
End Sub
Function CellUsedinFormula(strFormula As String) As Boolean
Dim ws As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim strTest As String
Dim strFirst As String
Dim bFound As Boolean
'Look in each worksheet for the strings in the list from "Trial Balance"
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> strSourceSht Then
On Error Resume Next
Set rng1 = ws.Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
'Look in formula cells only
If Not rng1 Is Nothing Then
'the string searches and later string comparisons are case insenstive
'so that the code can be easily modified to look for text rather than numeric strings
Set rng2 = rng1.Find(strFormula, , xlFormulas, xlPart, xlByRows, , False)
'For a case senstive search make the last argument TRUE, ie
'Set rng2 = rng1.Find(strFormula, , xlFormulas, xlPart, xlByRows, , TRUE)
'If the string is found, used a regular expression UDF to test for an exact match
If Not rng2 Is Nothing Then
strTest = LCase$(strFormula)
bFound = ExactMatch(strTest, rng2)
If bFound Then Exit For
strFirst = rng2.Address
Do
Set rng2 = rng1.FindNext(rng2)
bFound = ExactMatch(strTest, rng2)
'If a valid reference is found then stop the search for the string
If bFound Then Exit For
Loop While Not rng2 Is Nothing And rng2.Address <> strFirst
Exit For
End If
End If
End If
Next
CellUsedinFormula = bFound
End Function
Function ExactMatch(ByVal strTest, ByVal rng2) As Boolean
Dim regex As Object
Dim regM As Object
Dim RegC As Object
Dim bDependentRange As Boolean
Set regex = CreateObject("vbscript.regexp")
regex.Pattern = "\d+"
regex.Global = True
Set regM = regex.Execute(rng2.Formula)
For Each RegC In regM
If StrComp(LCase$(strTest), RegC, vbBinaryCompare) = 0 Then
If rng2.Parent.Name = strKeySht Then
ExactMatch = True
Else
'Call the recursive dependents function to test if this string
'is eventually referred to on P&L Forecast
bDependentRange = oneCellsDependents(rng2)
If bDependentRange Then
'exit on a successful match
ExactMatch = True
Exit Function
End If
End If
End If
Next
End Function
Function oneCellsDependents(ByVal rng2) As Boolean
'initial code credited to Bill Manville
'brettdj adapted this code from a post by mike rickson
Dim strAddress As String
Dim rngReturn As Range
Dim i As Long
Dim lPreCount As Long
Dim bFndTarget As Boolean
'set the point to return to
Set rngReturn = Selection
strAddress = rng2.Parent.Name & "!" & rng2.Address
' use the NavigateArrow method to follow cell dependencies
With rng2
.ShowDependents
.NavigateArrow dodependents, 1
'recursive loop through dependents
Do Until ActiveCell.Parent.Name & "!" & ActiveCell.Address = strAddress
lPreCount = lPreCount + 1
.NavigateArrow dodependents, lPreCount
If ActiveCell.Parent.Name = strKeySht Then
oneCellsDependents = True
Exit Do
Else
'recursive function call below
bFndTarget = oneCellsDependents(ActiveCell)
'successful search. Leave function
If bFndTarget = True Then
oneCellsDependents = True
GoTo LeaveMe
End If
End If
'next dependent
.NavigateArrow dodependents, lPreCount + 1
Loop
If oneCellsDependents Then GoTo LeaveMe
'remove the auditing arrows
ActiveCell.ShowDependents Remove:=True
End With
'Return selection to where it was
With rngReturn
.Parent.Activate
.Select
End With
LeaveMe:
End Function
Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.
Comments (0)