Excel macros for QOL formatting
'==============================================================
' MacabacusLite.bas (v6)
'
' INSTALL
' Alt+F11 > remove any old MacabacusLite module (No to export)
' > right-click VBAProject (PERSONAL.XLSB) > Import File > this.
' Ctrl+S. Then Alt+F8 > SetupShortcuts > Run (once; auto after that).
'
' KEY MAP
' Ctrl+Shift+K fill cycle (4 colours, last 2 are yours)
' Ctrl+Shift+1 number 0/1/2 dp, commas, (neg), 0 -> em dash
' Ctrl+Shift+2 date dd-mmm-yy / 0000"A" / 0000"E"
' Ctrl+Shift+5 percent 0/1/2 dp, commas
' Ctrl+Shift+8 multiple 0/1/2 dp, commas ("x")
' Ctrl+Shift+Alt+arrow toggle top/bottom/left/right edge border
' Ctrl+Shift+7 outside border only (box, no interior lines)
' Ctrl+Shift+- remove all borders
' Ctrl+, Ctrl+. increase / decrease decimals
' Ctrl+; font toggle black -> blue
' Ctrl+' font cycle black/blue/green/purple/red
' Ctrl+Shift+[ ] cycle precedents / dependents
' Ctrl+Shift+G B trace go-deeper / back
' Esc reset trace (next [ or ] starts fresh on current cell)
'==============================================================
Option Explicit
' ---- trace session state ----
Private gRe As Object
Private gStack As Collection
Private gSibs As Collection
Private gDir As String
'==============================================================
' SHORTCUT BINDING
'==============================================================
Sub Auto_Open()
SetupShortcuts
End Sub
Sub SetupShortcuts()
On Error Resume Next
' formatting
Application.OnKey "+^k", "CycleFillColor"
Application.OnKey "+^1", "CycleNumberFormat"
Application.OnKey "+^2", "CycleDateFormat"
Application.OnKey "+^5", "CyclePercentFormat"
Application.OnKey "+^8", "CycleMultipleFormat"
' edge borders on Ctrl+Shift+Alt+arrows (Ctrl+Shift+arrow stays native select-to-edge)
Application.OnKey "+^%{UP}", "BorderTop"
Application.OnKey "+^%{DOWN}", "BorderBottom"
Application.OnKey "+^%{LEFT}", "BorderLeft"
Application.OnKey "+^%{RIGHT}", "BorderRight"
Application.OnKey "+^7", "BordersOutline"
Application.OnKey "+^-", "BordersNone"
' decimals
Application.OnKey "^,", "IncreaseDecimals"
Application.OnKey "^.", "DecreaseDecimals"
' font
Application.OnKey "^;", "ToggleBlackBlue"
Application.OnKey "^'", "CycleFontColorFull"
' tracing
Application.OnKey "+^{[}", "PrecedentCycle"
Application.OnKey "+^{]}", "DependentCycle"
Application.OnKey "+^g", "TraceDescend"
Application.OnKey "+^b", "TraceBack"
Application.OnKey "{ESC}", "ResetTrace"
On Error GoTo 0
End Sub
Sub RemoveShortcuts()
Dim keys As Variant, k As Variant
keys = Array("+^k", "+^1", "+^2", "+^5", "+^8", "+^7", "+^-", _
"+^%{UP}", "+^%{DOWN}", "+^%{LEFT}", "+^%{RIGHT}", _
"^,", "^.", "^;", "^'", _
"+^{[}", "+^{]}", "+^g", "+^b", "{ESC}")
On Error Resume Next
For Each k In keys: Application.OnKey CStr(k): Next k
On Error GoTo 0
End Sub
'==============================================================
' FILL CYCLE (Ctrl+Shift+K) none -> 1 -> 2 -> 3 -> 4 -> none
'==============================================================
Sub CycleFillColor()
Dim cols As Variant
cols = Array( _
RGB(255, 255, 0), _
RGB(210, 242, 255), _
RGB(226, 239, 218), _
RGB(252, 228, 214)) ' REPLACE cols 3 & 4 with your bank's RGB
Dim c As Range: Set c = Selection.Cells(1, 1)
Dim i As Long, idx As Long
If c.Interior.Pattern = xlNone Then
idx = 0
Else
idx = UBound(cols) + 1
For i = LBound(cols) To UBound(cols)
If c.Interior.Color = cols(i) Then idx = i + 1: Exit For
Next i
End If
If idx > UBound(cols) Then
Selection.Interior.Pattern = xlNone
Else
Selection.Interior.Color = cols(idx)
End If
End Sub
'==============================================================
' NUMBER FORMAT CYCLES
'==============================================================
Sub CycleNumberFormat()
Dim z As String: z = """" & ChrW(8211) & """" ' zero shown as en dash: "–" (matches Macabacus)
CycleFormat Array( _
"#,##0;(#,##0);" & z, _
"#,##0.0;(#,##0.0);" & z, _
"#,##0.00;(#,##0.00);" & z)
End Sub
Sub CycleDateFormat()
CycleFormat Array("dd-mmm-yy", "0000""A""", "0000""E""")
End Sub
Sub CyclePercentFormat()
CycleFormat Array("#,##0%", "#,##0.0%", "#,##0.00%")
End Sub
Sub CycleMultipleFormat()
CycleFormat Array("#,##0""x""", "#,##0.0""x""", "#,##0.00""x""")
End Sub
Private Sub CycleFormat(fmts As Variant)
Dim cur As String, i As Long, idx As Long
If Selection Is Nothing Then Exit Sub
cur = Selection.Cells(1, 1).NumberFormat
idx = -1
For i = LBound(fmts) To UBound(fmts)
If fmts(i) = cur Then idx = i: Exit For
Next i
idx = idx + 1
If idx > UBound(fmts) Then idx = LBound(fmts)
Selection.NumberFormat = fmts(idx)
End Sub
'==============================================================
' BORDERS
'==============================================================
Sub BorderTop(): ToggleEdge xlEdgeTop: End Sub
Sub BorderBottom(): ToggleEdge xlEdgeBottom: End Sub
Sub BorderLeft(): ToggleEdge xlEdgeLeft: End Sub
Sub BorderRight(): ToggleEdge xlEdgeRight: End Sub
Private Sub ToggleEdge(edge As Long)
Dim b As Border
Set b = Selection.Borders(edge)
If b.LineStyle = xlContinuous And b.Weight = xlThin Then
b.LineStyle = xlNone ' already a normal line -> remove it
Else
b.LineStyle = xlContinuous ' none / dotted / thick -> force normal line
b.Weight = xlThin
b.ColorIndex = xlAutomatic
End If
End Sub
Sub BordersOutline() ' Ctrl+Shift+7 - outside edge of the whole selection only
Dim edges As Variant, e As Variant
edges = Array(xlEdgeLeft, xlEdgeRight, xlEdgeTop, xlEdgeBottom)
For Each e In edges
With Selection.Borders(e)
.LineStyle = xlContinuous
.Weight = xlThin
End With
Next e
End Sub
Sub BordersNone() ' Ctrl+Shift+- - strip all borders from the selection
Selection.Borders.LineStyle = xlNone
End Sub
'==============================================================
' INCREASE / DECREASE DECIMALS (Ctrl+, Ctrl+.)
'==============================================================
Sub IncreaseDecimals()
Dim c As Range
Application.ScreenUpdating = False
For Each c In Selection.Cells
c.NumberFormat = AdjustDecimals(c.NumberFormat, 1)
Next c
Application.ScreenUpdating = True
End Sub
Sub DecreaseDecimals()
Dim c As Range
Application.ScreenUpdating = False
For Each c In Selection.Cells
c.NumberFormat = AdjustDecimals(c.NumberFormat, -1)
Next c
Application.ScreenUpdating = True
End Sub
Private Function AdjustDecimals(fmt As String, delta As Long) As String
If StrComp(Trim$(fmt), "General", vbTextCompare) = 0 Then
AdjustDecimals = IIf(delta > 0, "0.0", "General")
Exit Function
End If
Dim sec() As String, i As Long
sec = Split(fmt, ";")
For i = LBound(sec) To UBound(sec)
sec(i) = AdjustSection(sec(i), delta)
Next i
AdjustDecimals = Join(sec, ";")
End Function
Private Function AdjustSection(s As String, delta As Long) As String
AdjustSection = s
If Len(s) = 0 Then Exit Function
Dim i As Long, ch As String
Dim inQuote As Boolean, esc As Boolean
Dim dotPos As Long, lastDigit As Long, lastDec As Long, hasDigit As Boolean
For i = 1 To Len(s)
ch = Mid$(s, i, 1)
If esc Then
esc = False
ElseIf ch = "\" Then
esc = True
ElseIf ch = """" Then
inQuote = Not inQuote
ElseIf Not inQuote Then
If ch = "0" Or ch = "#" Or ch = "?" Then
hasDigit = True: lastDigit = i
If dotPos > 0 Then lastDec = i
ElseIf ch = "." And dotPos = 0 Then
dotPos = i
End If
End If
Next i
If Not hasDigit Then Exit Function
If delta > 0 Then
If dotPos = 0 Then
AdjustSection = Left$(s, lastDigit) & ".0" & Mid$(s, lastDigit + 1)
Else
Dim insAt As Long: insAt = IIf(lastDec > 0, lastDec, dotPos)
AdjustSection = Left$(s, insAt) & "0" & Mid$(s, insAt + 1)
End If
ElseIf delta 0 And dotPos > 0 And lastDec > 0 Then
Dim t As String, after As String
t = Left$(s, lastDec - 1) & Mid$(s, lastDec + 1)
after = Mid$(t, dotPos + 1, 1)
If Not (after = "0" Or after = "#" Or after = "?") Then
t = Left$(t, dotPos - 1) & Mid$(t, dotPos + 1)
End If
AdjustSection = t
End If
End Function
'==============================================================
' FONT COLOUR
'==============================================================
Sub ToggleBlackBlue() ' Ctrl+;
If Selection.Cells(1, 1).Font.Color = RGB(0, 0, 255) Then
Selection.Font.Color = RGB(0, 0, 0)
Else
Selection.Font.Color = RGB(0, 0, 255)
End If
End Sub
Sub CycleFontColorFull() ' Ctrl+'
Dim cols As Variant
cols = Array(RGB(0, 0, 0), RGB(0, 0, 255), RGB(0, 128, 0), RGB(128, 0, 128), RGB(255, 0, 0))
Dim cur As Long, i As Long, idx As Long
cur = Selection.Cells(1, 1).Font.Color
idx = 0
For i = LBound(cols) To UBound(cols)
If cols(i) = cur Then idx = i + 1: Exit For
Next i
If idx > UBound(cols) Then idx = LBound(cols)
Selection.Font.Color = cols(idx)
End Sub
'==============================================================
' TRACE
'==============================================================
Sub PrecedentCycle(): CycleDir "P": End Sub
Sub DependentCycle(): CycleDir "D": End Sub
Sub TraceDescend()
' Re-anchor on the cell you're parked on and trace from there.
If gDir = "" Then gDir = "P"
Set gSibs = Nothing ' clear current list so CycleDir rebuilds on ActiveCell
CycleDir gDir
End Sub
Sub ResetTrace() ' Esc - drop the current cycle so the next [ or ] starts fresh
Set gSibs = Nothing
gDir = ""
On Error Resume Next
Application.CutCopyMode = False ' keep Esc's normal "clear the copy marquee" behaviour
On Error GoTo 0
End Sub
Sub TraceBack()
If gStack Is Nothing Then Exit Sub
If gStack.Count = 0 Then MsgBox "Nothing to step back to.", vbInformation: Exit Sub
Dim r As Range
On Error Resume Next
Set r = gStack(gStack.Count)
gStack.Remove gStack.Count
On Error GoTo 0
If Not r Is Nothing Then GoToRange r
End Sub
Private Sub CycleDir(dir As String)
' If we already have a list for this direction AND the cursor is on one of
' its members, step to the next member. This keeps the cycle locked to the
' ORIGINAL cell's precedents/dependents - it never drills into a member's
' own inputs. (Use Ctrl+Shift+G to deliberately drill into a member.)
If gDir = dir And Not gSibs Is Nothing Then
Dim pos As Long: pos = IndexInList(ActiveCell, gSibs)
If pos > 0 Then
pos = pos + 1
If pos > gSibs.Count Then pos = 1
GoToRange gSibs(pos)
Exit Sub
End If
End If
' Otherwise treat the active cell as a fresh anchor and build its list.
Dim cur As Range: Set cur = ActiveCell
Dim lst As Collection
Application.ScreenUpdating = False
Application.Cursor = xlWait
If dir = "P" Then
Set lst = PrecedentsOf(cur)
Else
Application.StatusBar = "Scanning workbook for dependents..."
Set lst = DependentsOf(cur)
End If
Application.StatusBar = False
Application.Cursor = xlDefault
Application.ScreenUpdating = True
If lst Is Nothing Then
MsgBox "VBScript.RegExp unavailable (Trust Center?). Ask for the regex-free build.", vbExclamation
Exit Sub
End If
If lst.Count = 0 Then
If dir = "P" Then
MsgBox cur.Address(External:=True) & " has no inputs - it's a hardcoded value.", vbInformation
Else
MsgBox "No cell in this workbook references " & cur.Address(External:=True) & ".", vbInformation
End If
Exit Sub
End If
PushHistory cur
Set gSibs = lst
gDir = dir
GoToRange lst(1)
End Sub
Private Function PrecedentsOf(cell As Range) As Collection
Dim out As New Collection
Set PrecedentsOf = out
If Not cell.HasFormula Then Exit Function
Dim re As Object: Set re = Rgx()
If re Is Nothing Then Set PrecedentsOf = Nothing: Exit Function
Dim m As Object, mt As Object, refStr As String, rng As Range
Set m = re.Execute(cell.Formula)
For Each mt In m
refStr = mt.Value
If InStr(refStr, "[") = 0 Then
Set rng = ResolveRef(refStr, cell.Worksheet)
If Not rng Is Nothing Then
On Error Resume Next
out.Add rng, rng.Address(External:=True)
On Error GoTo 0
End If
End If
Next mt
End Function
Private Function DependentsOf(target As Range) As Collection
Dim out As New Collection
Set DependentsOf = out
Dim re As Object: Set re = Rgx()
If re Is Nothing Then Set DependentsOf = Nothing: Exit Function
Dim tgt As Range: Set tgt = target.Cells(1, 1)
Dim ws As Worksheet, fcells As Range, c As Range
For Each ws In tgt.Parent.Parent.Worksheets
Set fcells = Nothing
On Error Resume Next
Set fcells = ws.UsedRange.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not fcells Is Nothing Then
For Each c In fcells
If FormulaHits(c, tgt, re) Then
On Error Resume Next
out.Add c, c.Address(External:=True)
On Error GoTo 0
End If
Next c
End If
Next ws
End Function
Private Function FormulaHits(formulaCell As Range, tgt As Range, re As Object) As Boolean
Dim m As Object, mt As Object, refStr As String, rng As Range
Set m = re.Execute(formulaCell.Formula)
For Each mt In m
refStr = mt.Value
If InStr(refStr, "[") = 0 Then
Set rng = ResolveRef(refStr, formulaCell.Worksheet)
If Not rng Is Nothing Then
If rng.Worksheet Is tgt.Worksheet Then
If Not Application.Intersect(rng, tgt) Is Nothing Then
FormulaHits = True: Exit Function
End If
End If
End If
End If
Next mt
End Function
Private Function Rgx() As Object
If gRe Is Nothing Then
On Error Resume Next
Set gRe = CreateObject("VBScript.RegExp")
On Error GoTo 0
If gRe Is Nothing Then Exit Function
gRe.Global = True
gRe.IgnoreCase = True
gRe.Pattern = "(?:(?:'[^']+'|\[[^\]]+\][^!'()]*|[A-Za-z_][A-Za-z0-9_.]*)!)?" & _
"\$?[A-Za-z]{1,3}\$?[0-9]+(?::\$?[A-Za-z]{1,3}\$?[0-9]+)?(?![A-Za-z0-9_(])"
End If
Set Rgx = gRe
End Function
Private Function ResolveRef(refStr As String, srcSheet As Worksheet) As Range
On Error Resume Next
Dim ws As Worksheet, addr As String, sheetPart As String, p As Long
p = InStr(refStr, "!")
If p > 0 Then
sheetPart = Left$(refStr, p - 1)
addr = Mid$(refStr, p + 1)
If Left$(sheetPart, 1) = "'" And Right$(sheetPart, 1) = "'" Then
sheetPart = Mid$(sheetPart, 2, Len(sheetPart) - 2)
sheetPart = Replace(sheetPart, "''", "'")
End If
Set ws = srcSheet.Parent.Worksheets(sheetPart)
If ws Is Nothing Then Exit Function
Set ResolveRef = ws.Range(addr)
Else
Set ResolveRef = srcSheet.Range(refStr)
End If
End Function
Private Sub GoToRange(rng As Range)
On Error Resume Next
Application.Goto Reference:=rng, Scroll:=False
On Error GoTo 0
End Sub
Private Sub PushHistory(r As Range)
If gStack Is Nothing Then Set gStack = New Collection
gStack.Add r
End Sub
Private Function IndexInList(c As Range, lst As Collection) As Long
On Error Resume Next
Dim i As Long, key As String
key = c.Worksheet.Name & "!" & c.Cells(1, 1).Address
For i = 1 To lst.Count
If (lst(i).Worksheet.Name & "!" & lst(i).Cells(1, 1).Address) = key Then
IndexInList = i
Exit Function
End If
Next i
On Error GoTo 0
End Function
