Here's some code I hope you don't need: a targeted 'recalculate' function.
Most Excel developers don't get huge workbooks that take twenty minutes to recalculate... It's our job to stop this kind of thing, right? But if you do, how do you get just one bit of the monster to calculate - the bit you're trying to debug, or explain the strange results in - when there's a long, long chain of dependencies on market data sources and external math libraries? The one thing you don't want to do is recalculate the whole workbook, but recalculating the cell with the F2 key is useless because it doesn't go right down the 'precedents' (Microsoft's term for the chain of cells and ranges that feed into your cell), no matter what you read in the documentation.
So I started writing a tool to record the chain of precedents, and found that really complex spreadsheets could produce so much dependency data that the text output was impossible to assimilate. What I found out next was that presenting this mass of data in a structured way breaks down because there are no tools that can represent cross-linkage without turning into a visual spaghetti, and the only good tool for representing the mess as a branching structure - the treeview control - is unstable in Excel at the best of times and blows up if there's more than 16 layers of recursion or more than 255 subnodes in any given node.
But the end result of this failed project was a tool that could explore the precedents, list them in a collection and, having discovered all the sources leading into a cell, back it's way out of the dependency chain while only calculating each cell once. That's efficient - not as quick as Excel's internal dependency chain, but it's often quicker than recalculating an over-complicated workbook. And it works a treat when Excel's dependency tree is broken, or blocked by named ranges, indirect references, and third-party libraries which place range pointers in a cell instead of range addresses.
Feel free to post your code if you get a visualisation tool to work! Also, please let me know if you can think of a way of identifying homogeneous blocks of formulae and enumerating them in one go, instead of repeating the search on cell after cell. It's not that it can't be done, but I can't see a way of doing it reliably and quickly enough to use on thousands of formulae.
Anyway, here's the code, complete with a snippet for putting it into an add-in and populating the popup 'cell' menu with a button that calls the function. As always, beware of spurious line breaks and syntax errors introduced by the Blogger platform's automatic formatting.
Option Explicit
Option Private Module
Private Sub CalculatePrecedents(rngCalc As Excel.Range, Optional bVerbose As Boolean = False)
' Recursive function to force calculation of a dependency chain
' with additional coding to prevent searching any range twice
On Error Resume Next
Static iRecurse As Long
Static colRanges As Scripting.Dictionary
Static colWorkbooks As Scripting.Dictionary
Static xlPriorCalcSetting As XlCalculation
Static iSearched As Long
Static iCalculated As Long
Static arrNames() As String
Static iCountNames As Long
Static sWorkbookName As String
Dim iCountPrecedents As Long
Dim rPrecedent As Excel.Range
Dim rCell As Excel.Range
Dim myName As Excel.Name
Dim strName As String
Dim strAddress As String
Dim strFormula As String
Dim iLen As Long
Dim i As Integer
Dim iMatch As Integer
Dim iNextChar As Integer
Dim iPrevChar As Integer
Dim boolIsName As Boolean
' Do we need new collections for the searched formulae and calculated ranges?
If iRecurse = 0 Or rngCalc.Worksheet.Parent.Name <> sWorkbookName Then
If colWorkbooks Is Nothing Then
Set colWorkbooks = New Scripting.Dictionary
End If
' save sets for current workbook
If Not (colWorkbooks.Exists("Ranges: " & sWorkbookName) Or colRanges Is Nothing) Then
colWorkbooks.Add "Ranges: " & sWorkbookName, colRanges
End If
' retrieve sets for newly-discovered workbook
sWorkbookName = rngCalc.Worksheet.Parent.Name
If colWorkbooks.Exists("Ranges: " & sWorkbookName) Then
Set colRanges = colWorkbooks("Ranges: " & sWorkbookName)
Else
Set colRanges = Nothing
End If
End If
If colRanges Is Nothing Or iRecurse = 0 Then
xlPriorCalcSetting = Application.Calculation
' Initialise the collection that prevents checking the same range twice:
Set colRanges = New Scripting.Dictionary
' initialise and populate the array of names: this is used for a fast
' search to see if a named range is referenced in a formula - a test
' that isn't reliably executed by Excel's native 'precedents' function
iCountNames = rngCalc.Worksheet.Parent.Names.Count
Application.StatusBar = "Trace precedents: collating named range addresses in " & sWorkbookName & "..."
If bVerbose = True Then
Debug.Print "Trace precedents: collating named range addresses in " & sWorkbookName & "..."
End If
If iCountNames > 0 Then
ReDim arrNames(1 To iCountNames)
For i = 1 To iCountNames
strName = ""
strName = rngCalc.Worksheet.Parent.Names(i).NameLocal
If InStr(1, strName, "!") > 0 Then
strName = left(strName, InStr(1, strName, "!") - 1)
End If
arrNames(i) = strName
Next i
' Sort in descending order: looking for the longest names first allows us
' to prevent a match on 'ABCDE' being masked by finding 'BCD'
BubbleSortOnLen arrNames, xlDescending
End If ' iCountNames > 0
Application.StatusBar = "Trace precedents: analysing first cell..."
If bVerbose = True Then
Debug.Print "Trace precedents: analysing first cell... '" & rngCalc.Worksheet.Name & "'!" & rngCalc.Address
End If
End If
' Check for ranges we've searched before.
' First check: it might be a single cell; if so, is it part of an array we've already analysed?
If rngCalc.Cells.Count = 1 Then
If rngCalc.HasArray Then
If colRanges.Exists("'" & rngCalc.Worksheet.Name & "'!" & rngCalc.CurrentArray) Then
GoTo ExitSub
Else
colRanges.Add "'" & rngCalc.Worksheet.Name & "'!" & rngCalc.CurrentArray, "Recursion " & CStr(iRecurse) & vbTab & "'" & rngCalc.Worksheet.Name & "'!" & rngCalc.AddressLocal & vbTab & "{" & rngCalc.Formula & "}"
End If
End If
' Exit if there's no formula; there can be no precedents
' Note that we had to check it wan't an array beforehand
If Not (IsNull(rngCalc.HasFormula) Or (rngCalc.HasFormula = True)) Then
GoTo ExitSub
End If
End If ' rngCalc.Cells.Count = 1
' Check that we haven't searched this range already - there's an overhead doing this, but it's better than repeated search and calculation
If colRanges.Exists("'" & rngCalc.Worksheet.Name & "'!" & rngCalc.AddressLocal) Then
GoTo ExitSub
Else
colRanges.Add "'" & rngCalc.Worksheet.Name & "'!" & rngCalc.AddressLocal, "Recursion " & CStr(iRecurse) & vbTab & "'" & rngCalc.Worksheet.Name & "'!" & rngCalc.AddressLocal
End If
' Keep track of recursion: this tells us when the search has been completed
If iRecurse < 0 Then
iRecurse = 0
End If
If iSearched Mod 10 = 0 Then
Application.StatusBar = "Trace precedents: searched " & Format(iSearched, "#,##0") & " Calculated " & Format(iCalculated, "#,##0") & " Recursion level " & iRecurse & " Cell '" & rngCalc.Worksheet.Name & "'!" & rngCalc.Address
End If
If bVerbose = True Then
Debug.Print "Trace precedents - search " & iSearched & ":" & vbTab & " Precedents of " & vbTab & "'" & rngCalc.Worksheet.Name & "'!" & rngCalc.AddressLocal & vbTab & " Formula: " & rngCalc.Formula & vbTab & " at recursion level " & iRecurse
End If
If rngCalc.Cells.Count = 1 Then
strFormula = ""
strFormula = LTrim(rngCalc.Formula)
' Check for named ranges in the formula: these are not
' recognized as reliably as "A1" specified addresses
' and will therefore not be recognised as precedents
For i = 1 To iCountNames Step 1
strName = ""
strName = arrNames(i)
iMatch = InStr(1, strFormula, strName, vbTextCompare)
If iMatch > 0 Then
boolIsName = True
' A name like "res" might well be a substring of another name, or of a
' function name. So we must establish that the string we've found isn't
' just a match for a named range: it's got to be in use as an address.
iLen = Len(strName)
iPrevChar = 0
iNextChar = 0
If iMatch + iLen = Len(strFormula) Then
iNextChar = 0
Else
iNextChar = iMatch + iLen + 1
Select Case Mid(strFormula, iNextChar, 1)
Case "(", Chr(34), ".", "!", "a" To "z", "A" To "Z", 0 To 9
'strName definitely isn't a named range
boolIsName = False
Case Else
' no action... move to next test
End Select
End If
If iMatch > 1 Then
iPrevChar = iMatch - 1
Select Case Mid(strFormula, iPrevChar, 1)
Case Chr(34), ".", "!", "a" To "z", "A" To "Z", 0 To 9
'strName definitely isn't a named range
boolIsName = False
Case Else
' no action... move to next test
End Select
End If
If boolIsName Then
iSearched = iSearched + 1
iRecurse = iRecurse + 1
CalculatePrecedents rngCalc.Worksheet.Parent.Names(strName).RefersToRange, bVerbose
iRecurse = iRecurse - 1
' Strip the matched name out of our formula string, so we only analyse it once:
strFormula = Application.WorksheetFunction.Substitute(strFormula, strName, "")
End If 'boolIsName
End If
Next i
iCountPrecedents = 0
iCountPrecedents = rngCalc.DirectPrecedents.Count
If iCountPrecedents > 0 Then
For Each rPrecedent In rngCalc.DirectPrecedents
iSearched = iSearched + 1
iRecurse = iRecurse + 1
CalculatePrecedents rPrecedent, bVerbose
iRecurse = iRecurse - 1
Next
End If ' .DirectPrecedents.Count = 0
Else
' unless it's an array formula, search each cell
If IsNull(rngCalc.FormulaArray) Then
For Each rCell In rngCalc.SpecialCells(xlCellTypeFormulas)
If rCell.HasFormula Then
iSearched = iSearched + 1
iRecurse = iRecurse + 1
CalculatePrecedents rCell, bVerbose
iRecurse = iRecurse - 1
End If
Next rCell
Else
' for an array, run the precedents of the entire range:
For Each rPrecedent In rngCalc.DirectPrecedents
iSearched = iSearched + 1
iRecurse = iRecurse + 1
CalculatePrecedents rPrecedent, bVerbose
iRecurse = iRecurse - 1
Next
End If
End If ' cells.count = 1
iCalculated = iCalculated + 1
If bVerbose = True Then
Debug.Print "Calculating cell " & iCalculated & " (recursion layer " & iRecurse & "): " & "'" & rngCalc.Worksheet.Name & "'!" & rngCalc.AddressLocal & vbTab & vbTab & rngCalc.Formula
End If
If bVerbose = True Then
Debug.Print vbTab & "Trace precedents - Calculation " & iCalculated & ":" & vbTab & "'" & rngCalc.Worksheet.Name & "'!" & rngCalc.AddressLocal & vbTab & " Formula: "; vbTab & rngCalc.Formula & " at recursion level " & iRecurse
End If
rngCalc.Calculate
ExitSub:
If iRecurse < 0 Then ' this is redundant in production code, but it'll save you grief in development
iRecurse = 0
End If
If iRecurse = 0 Then
If bVerbose = True Then
Application.StatusBar = "Trace precedents searched " & Format(iSearched, "#,##0") & " Calculated " & Format(iCalculated, "#,##0") & " Recursion returned to " & iRecurse
End If
Erase arrNames
Application.StatusBar = False
iSearched = 0
iCalculated = 0
Set colRanges = Nothing
Application.Calculation = xlPriorCalcSetting
End If
End Sub
Private Sub BubbleSortOnLen(ByRef arrStrings() As String, Optional SortOrder As Excel.XlSortOrder = xlAscending)
' Modified Bubble Sort: sort an array of strings by length
Dim iFirst As Integer
Dim iLast As Integer
Dim i As Integer
Dim j As Integer
Dim sTemp As String
iFirst = LBound(arrStrings)
iLast = UBound(arrStrings)
If SortOrder = xlAscending Then
For i = iFirst To iLast - 1
For j = i + 1 To iLast
If Len(arrStrings(i)) > Len(arrStrings(j)) Then
sTemp = arrStrings(j)
arrStrings(j) = arrStrings(i)
arrStrings(i) = sTemp
End If
Next j
Next i
Else ' SortOrder = xlDescending
For i = iFirst To iLast - 1
For j = i + 1 To iLast
If Len(arrStrings(i)) < Len(arrStrings(j)) Then
sTemp = arrStrings(j)
arrStrings(j) = arrStrings(i)
arrStrings(i) = sTemp
End If
Next j
Next i
End If ' sortorder
End Sub
Public Sub CalculateSelection()
' Called from a button in a menubar or popup
On Error Resume Next
Selection.Calculate
End Sub
Public Sub GetPrecedents()
' Called from a button in a menubar or popup
CalculatePrecedents Selection, False
End Sub
And here's the boilerplate code that puts Calculate Precedents into an add-in's 'Workbook' object module and adds our function to the right-click popup menu for an Excel worksheet:
Option Explicit
Private Sub Workbook_AddinInstall()
Dim objCbtn As Office.CommandBarButton
Dim objCbtn2 As Office.CommandBarButton
Dim objCbar As Office.CommandBar
With Application.CommandBars("Cell")
Set objCbtn = .FindControl(, , "Calculate Precedents", , True)
Do Until objCbtn Is Nothing
objCbtn.Delete
Set objCbtn = .FindControl(, , "Calculate Precedents", , True)
Loop
Set objCbtn = .Controls.Add(msoControlButton, , , , True)
End With 'Application.CommandBars("Cell")
With objCbtn
.BeginGroup = True
.Caption = "Calculate Precedents"
.DescriptionText = "Locate all precedents and calculate recursively"
.OnAction = "GetPrecedents"
.Tag = "Calculate Precedents"
.TooltipText = "Locate all precedents and calculate recursively"
.FaceId = 452
End With 'objCbtn
Set objCbtn = Nothing
With Application.CommandBars("Cell")
Set objCbtn = .FindControl(, , "Calculate Selection", , True)
Do Until objCbtn Is Nothing
objCbtn.Delete
Set objCbtn = .FindControl(, , "Calculate Selection", , True)
Loop
Set objCbtn = .Controls.Add(msoControlButton, , , , True)
End With 'Application.CommandBars("Cell")
With objCbtn
.Caption = "Calculate Selection"
.OnAction = "CalculateSelection"
.Tag = "Calculate Selection"
.TooltipText = "Calculate the selected range"
.FaceId = 346
End With 'objCbtn
Set objCbtn = Nothing
End Sub
Private Sub Workbook_AddinUninstall()
Dim objCbtn As Office.CommandBarButton
With Application.CommandBars("Cell")
Set objCbtn = .FindControl(, , "Calculate Precedents", , True)
If Not objCbtn Is Nothing Then
objCbtn.Delete
End If
Set objCbtn = .FindControl(, , "Calculate Selection", , True)
If Not objCbtn Is Nothing Then
objCbtn.Delete
End If
End With 'Application.CommandBars("Cell")
Set objCbtn = Nothing
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call Workbook_AddinUninstall
End Sub
Private Sub Workbook_Open()
Call Workbook_AddinInstall
End Sub
No comments:
Post a Comment