Option Explicit
Private mMatch As Variant
Private mMatches As Variant
Private mSubmatch As Variant
Private mRegExpr As Variant
Private Const mCELL_ADDRESS_PATTERN = "([$]{0,1})([A-Z]{1,COL_LEN})([$]{0,1})(\d{1,NUM_LEN})"
Private Const mTOKEN_STRING = "T_O_K_E_N_"
Public Sub BuildFormula(Optional CurrentSheet As Variant)
Dim rng As Range, cell As Range
Dim lngTemp As Long
Dim varTemp As Variant, varArray As Variant
Dim strFormula As String, strPattern As String
On Error Resume Next
'Default to active sheet
If IsMissing(CurrentSheet) Then
Set CurrentSheet = ActiveSheet
'Allow sheet object or sheet name or sheet index
ElseIf Not IsObject(CurrentSheet) Then
Set CurrentSheet = Sheets(CurrentSheet)
End If
'Look at formulas only, error check prevents error if no formulas in the sheet
Set rng = CurrentSheet.Cells.SpecialCells(xlFormulas)
On Error GoTo 0
'Exit if there are no formulas
If IsNothing(rng) Then
Exit Sub
End If
'Set application properties
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
'Create module level regular expression objects
Call CreateRegExpr
strPattern = GetCellAddressPattern
For Each cell In rng.Cells
varArray = varTemp
'Tokenize any valid cell addresses which may be embedded within string
strFormula = TokenizeFormula(cell.Formula, varArray)
'Do my work here
Debug.Print
Debug.Print "Before: " & strFormula
strFormula = ReplaceRef(strFormula, strPattern, "Abs", 2)
Debug.Print "After: " & strFormula
Call ListMatches(strFormula, strPattern)
'If embedded strings processed then reverse the tokenization process
If IsArray(varArray) Then
cell.Formula = ReverseTokenizeFormula(strFormula, varArray)
End If
Next
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
Set rng = Nothing: Set cell = Nothing
Set mMatch = Nothing: Set mMatches = Nothing: Set mSubmatch = Nothing: Set mRegExpr = Nothing
End Sub 'BuildFormula
Private Sub CreateRegExpr(Optional PatternText As String, _
Optional SearchAll As Boolean, _
Optional IgnoreCase As Boolean)
'Create regular expression object
Set mRegExpr = CreateObject("vbscript.regexp")
With mRegExpr
mRegExpr.Global = SearchAll
mRegExpr.Pattern = PatternText
mRegExpr.IgnoreCase = IgnoreCase
End With
End Sub 'CreateRegExpr
Private Function TokenizeFormula(ByVal FormulaText As String, _
ByRef ArrayText As Variant) As String
Dim lngTemp As Long
Dim strTemp As String
With mRegExpr
.Global = True
.IgnoreCase = True
'glw4 .Pattern = """.*"""
.Pattern = """.+?"""
Set mMatches = .Execute(FormulaText)
End With
If mMatches.Count Then
For Each mMatch In mMatches
If IsArray(ArrayText) Then
lngTemp = lngTemp + 1
ReDim Preserve ArrayText(lngTemp)
Else
ReDim ArrayText(lngTemp)
End If
With mMatch
ArrayText(lngTemp) = .Value
strTemp = mTOKEN_STRING & lngTemp
FormulaText = Replace$(FormulaText, .Value, strTemp)
End With
Next mMatch
End If
TokenizeFormula = FormulaText
End Function 'TokenizeFormula
'AddressType = Abs $A$1, Rel A1, Row A$1, Col $A1
Private Function ReplaceRef(SearchText As String, _
PatternText As String, _
AddressType As String, _
FormulaRef As Integer)
Dim NewForm As String
With mRegExpr
.Global = True
.Pattern = PatternText
.IgnoreCase = True
Set mMatches = .Execute(SearchText)
End With
'If not enough matches we are finished
If mMatches.Count < FormulaRef Then
ReplaceRef = SearchText
Exit Function
End If
'Submatches are zero based so 1st Submatch = Match(n-1)
Set mSubmatch = mMatches(FormulaRef - 1).Submatches
Select Case Application.WorksheetFunction.Proper(AddressType)
Case "Rel"
NewForm = mSubmatch(1) & mSubmatch(3)
Case "Abs"
NewForm = "$" & mSubmatch(1) & "$" & mSubmatch(3)
Case "Col"
NewForm = "$" & mSubmatch(1) & mSubmatch(3)
Case "Row"
NewForm = mSubmatch(1) & "$" & mSubmatch(3)
Case Else
'conversion input was invalid
ReplaceRef = SearchText
Exit Function
End Select
ReplaceRef = Application.WorksheetFunction.Replace(SearchText, mMatches(FormulaRef - 1).FirstIndex + 1, Len(mMatches(FormulaRef - 1)), NewForm)
End Function 'ReplaceRef
Private Sub ListMatches(SearchText As String, PatternText As String)
Dim RegEx, Submatch, Match, Matches
Dim NewForm As String
With mRegExpr
.Global = True
.Pattern = PatternText
.IgnoreCase = True
Set Matches = .Execute(SearchText)
End With
If Matches.Count Then
Debug.Print
Debug.Print SearchText, PatternText
For Each Match In Matches
With Match
Debug.Print "Match found at " & .FirstIndex & ", value is " & .Value & ", Length is " & .Length
End With
Next Match
End If
End Sub 'ListMatches
Private Function GetCellAddressPattern() As String
Dim lngTemp As Long
Dim strTemp As String
strTemp = mCELL_ADDRESS_PATTERN
'Calculate width of maximum row number
lngTemp = Len(Trim$(Str$(Cells.Rows.Count)))
strTemp = Replace$(strTemp, "NUM_LEN", lngTemp)
'Calculate width of maximum columns
lngTemp = 2
'First set includes single values (eg a thru z) + 26 sets of doubles (eg aa thru zz)
Do While 27 * 26 ^ (lngTemp - 1) < Cells.Columns.Count
lngTemp = lngTemp + 1
Loop
strTemp = Replace$(strTemp, "COL_LEN", lngTemp)
GetCellAddressPattern = strTemp
End Function 'GetCellAddressPattern
Private Function ReverseTokenizeFormula(ByVal FormulaText As String, _
ByRef ArrayText As Variant) As String
Dim lngTemp As Long
Dim strTemp As String
For lngTemp = LBound(ArrayText) To UBound(ArrayText)
strTemp = mTOKEN_STRING & lngTemp
FormulaText = Replace$(FormulaText, strTemp, ArrayText(lngTemp))
Next lngTemp
ReverseTokenizeFormula = FormulaText
End Function 'ReverseTokenizeFormula
Private Function IsNothing(Parm As Variant)
On Error Resume Next
IsNothing = (Parm Is Nothing)
Err.Clear
On Error GoTo 0
End Function 'IsNothing
