Jim Thomlinson:
...
I can not count the number of times that I have been auditing a formula trying to match up brackets and commas and...
...
I'd been debating with myself whether to post this or not, but WTH. Somewhat stripped down from what I use,
'-- begin VBA ------
Option Explicit
Function foo( _
rng As Range, _
Optional bars As Boolean = False, _
Optional fcnpat As String = "" _
) As String
'-----------------------------------
'Copyright (c) 2008 Harlan Grove.
'
'This code is free software; you can redistribute it and/or modify
'it under the terms of the GNU General Public License as published
'by the Free Software Foundation; either version 2 of the License,
'or (at your option) any later version.
'-----------------------------------
'requires a reference to VBScript Regular Expressions 5.5
Const NS As Long = 4 'should be >= 2
Const SEP As String = "," 'function argument separator
'SEP could be queried from the OS - left as an exercise
Dim k As Long, lvl As Long, f As String, t As String
Dim nas As Long, nlp As Long, nrp As Long
Dim sc As Variant, xc As Variant, fc As Variant
Dim re As RegExp, mc As MatchCollection, m As Match
If Not rng.Cells(1).HasFormula Then Exit Function
'only processing 1st cell in rng
'handling all cells in rng left as an exercise
f = rng.Cells(1).Formula
Set re = New RegExp
'first find all string literals . . .
re.Global = True
re.Pattern = """[^""]*(""""[^""]*)*"""
Set mc = re.Execute(f)
re.Global = False
'. . . and replace 'em with ad hoc tokens
If mc.Count > 0 Then
ReDim sc(1 To mc.Count)
For k = 1 To mc.Count
sc(k) = mc(k - 1).Value
f = re.Replace(f, Format(k, "\:\s\t\r00\:"))
Next k
End If
Set mc = Nothing
'next find all non-function-call parametrized terms . . .
re.Global = True
re.Pattern = "(?:[^_A-Z.0-9])\([^()]+\)"
Set mc = re.Execute(f)
re.Global = False
'. . . and replace 'em with other ad hoc tokens
If mc.Count > 0 Then
ReDim xc(1 To mc.Count)
For k = 1 To mc.Count
xc(k) = mc(k - 1).Value
f = re.Replace(f, Format(k, "\:\p\e\x00\:"))
Next k
End If
Set mc = Nothing
'now remove all remaining whitespace
re.Global = True
re.Pattern = vbLf & " *"
f = re.Replace(f, "")
re.Global = False
'using a state machine to add the indentation
lvl = 0 'start off at function call level zero
nas = InStr(1, f, SEP)
nlp = InStr(1, f, "(")
nrp = InStr(1, f, ")")
k = nlp 'if formula is syntactically valid, nlp < nac or nrp
Do While k > 0
If k = nas Then
'arg separator, no level change
f = Left(f, k) & vbLf & String(NS * lvl, " ") & Mid(f, k + 1)
ElseIf k = nlp Then
'left paren, begin next level
lvl = lvl + 1
f = Left(f, k) & vbLf & String(NS * lvl, " ") & Mid(f, k + 1)
ElseIf k = nrp Then
'right paren, end current level
lvl = lvl - 1
f = Left(f, k - 1) & vbLf & String(NS * lvl, " ") & Mid(f, k)
Else 'this shouldn't happen!
Debug.Assert 1 = 0 'FUBAR
End If
Debug.Assert lvl >= 0 'also FUBAR, i.e., shouldn't happen
k = k + 2 + NS * lvl 'where we start the next char search
nas = InStr(k, f, SEP)
nlp = InStr(k, f, "(")
nrp = InStr(k, f, ")")
'set k to next arg separator or parenthesis, if any
'if none of them remaining, k set to 0, so loop will end
k = nas
If k = 0 Or nlp < k Then k = nlp
If k = 0 Or nrp < k Then k = nrp
Loop
'find all argument lists that DON'T contain function calls . . .
re.Global = True
re.Pattern = "\((\n +[^ (),]*,?)+\)"
Set mc = re.Execute(f)
re.Pattern = vbLf & " +"
'. . . and compress them back to a single line
'note: this is done back to front because each replacement alters
'char positions of matches to its right BUT NOT to its left
For k = mc.Count To 1 Step -1
Set m = mc(k - 1)
t = re.Replace(m.Value, "")
f = Left(f, m.FirstIndex) & t & Mid(f, m.FirstIndex + m.Length + 1)
Next k
Set mc = Nothing
'OPTIONAL! remove indentation of SINGLE function calls within
'function calls the names of which would be specified in fcnpat
If fcnpat <> "" Then fc = Split(fcnpat, SEP)
If IsArray(fc) Then
For k = LBound(fc, 1) To UBound(fc, 1)
re.Pattern = "(" & fc(k) & ")\(\n +([^ ]+)?\n *\)"
f = re.Replace(f, "$1($2)")
Next k
Erase fc
End If
'OPTIONAL! add vertical bars to indented formula
If bars Then
re.Pattern = String(NS, " ")
f = re.Replace(f, String(NS - 2, " ") & "| ")
End If
Set re = Nothing
'restore non-function-call parenthesized expressions
If IsArray(xc) Then
For k = LBound(xc, 1) To UBound(xc, 1)
f = Replace(f, Format(k, "\:\p\e\x00\:"), xc(k), 1, 1)
Next k
Erase xc
End If
'restore string literals
If IsArray(sc) Then
For k = LBound(sc, 1) To UBound(sc, 1)
f = Replace(f, Format(k, "\:\s\t\r00\:"), sc(k), 1, 1)
Next k
Erase sc
End If
foo = f
End Function
Sub testit()
'select a cell containing a nast formula and run this macro
If Not TypeOf Selection Is Range Then Exit Sub
MsgBox foo(Selection)
MsgBox foo(Selection, True)
MsgBox foo(Selection, True, "IS[A-Z]+,N,T")
End Sub
'-- end VBA ------