Improved version:
Sub ParseMultipleLinkFormulas()
Dim Parsed() As String
Dim objRegExp As Object
Dim objMatchCollection As Object
Dim sPattern As String
Dim fCount As Long
Dim fCounter As Long
Dim myRowsToProcess As Long
Dim myColumnsToProcess As Long
Dim StartCell As Range
Dim PostCell As Range
Dim FirstParcedCell As Range
Dim AggregateFormula As String
Dim FirstLinkPosition As String
Dim SecondLinkPosition As String
FirstLinkPosition = InStr(1, ActiveCell.Formula, "'!")
SecondLinkPosition = InStr(FirstLinkPosition + 1, ActiveCell.Formula, "'!")
If SecondLinkPosition - FirstLinkPosition > 0 Then
Dim FormulaStr As String
If Len(ActiveCell.Formula) > 0 Then
FormulaStr = Replace(ActiveCell.Formula, Chr(10), "")
Else
MsgBox "Start-cell formula is empty ... discontinuing ...'"
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
Exit Sub
End If
'**************************** Following Resets Used Range ***********************************
With ActiveSheet
maxrows = .Rows.Count
maxcolumns = .Columns.Count
End With
myRowsToProcess = Cells.Find(What:="*", After:=ActiveSheet.Cells(1, 1), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
myColumnsToProcess = Cells.Find(What:="*", After:=ActiveSheet.Cells(1, 1), LookIn:=xlFormulas,
_
LookAt:=xlWhole, SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
myRowsToProcess = IIf(myRowsToProcess > maxrows, maxrows, myRowsToProcess)
myColumnsToProcess = IIf(myColumnsToProcess > maxcolumns, maxcolumns, myColumnsToProcess)
Range(Cells(1, myColumnsToProcess + 1), Cells(maxrows, maxcolumns)).EntireColumn.Delete
Range(Cells(myRowsToProcess + 1, 1), Cells(maxrows, maxcolumns)).EntireRow.Delete
ActiveSheet.UsedRange
'**********************************************************************************************
sPattern = "(-?(('[\s\S]*?'!\w+)|(\([\s\S]*?\))|([^-+*/^<>=]+)))([-+*/^<>][<>=]?|$)"
Set objRegExp = CreateObject("VBScript.RegExp")
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.MultiLine = True
objRegExp.Pattern = sPattern
If objRegExp.test(FormulaStr) = True Then
Set objMatchCollection = objRegExp.Execute(FormulaStr)
ReDim Parsed(1 To objMatchCollection.Count, 1 To 2)
For fCount = 1 To objMatchCollection.Count
Parsed(fCount, 1) = objMatchCollection(fCount - 1).SubMatches(0)
Parsed(fCount, 2) = objMatchCollection(fCount - 1).SubMatches(5)
Next fCount
End If
On Error Resume Next
If Len(Parsed(2, 1)) > 0 Then
If Err.Number > 0 Then
GoTo If_Error
End If
Set StartCell = ActiveCell
Set PostCell = ActiveSheet.Cells(ActiveSheet.UsedRange.Rows.Count + 2, ActiveCell.Column)
Set FirstParcedCell = PostCell
AggregateFormula = "="
fCounter = 1
For fCounter = 1 To fCount - 1 Step 1
If Len(Parsed(fCounter, 1)) > 0 Then
With PostCell.Offset(fCounter - 1, 0)
.Formula = "=" & Parsed(fCounter, 1)
.NumberFormat = StartCell.NumberFormat
End With
With PostCell.Offset(fCounter - 1, -1)
.Value = "'" & IIf(IsNumeric(Parsed(fCounter, 1)), "Explain: ",
Parsed(fCounter, 1))
.NumberFormat = StartCell.NumberFormat
End With
AggregateFormula = AggregateFormula & PostCell.Offset(fCounter - 1, 0).Address &
Parsed(fCounter, 2)
End If
Next fCounter
With PostCell.Offset(fCounter, 0)
.Formula = AggregateFormula
.NumberFormat = StartCell.NumberFormat
End With
With PostCell.Offset(fCounter, -1)
.Value = " Total"
.NumberFormat = StartCell.NumberFormat
End With
PostCell.Offset(fCounter, 0).Select
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.Weight = xlThick
End With
If StartCell.Value = PostCell.Offset(fCounter, 0).Value Then
With StartCell
.Formula = "=" & PostCell.Offset(fCounter, 0).Address
.BorderAround LineStyle:=xlContinuous, ColorIndex:=5, Weight:=xlMedium
End With
'With PostCell.Offset(fCounter, 0)
' .BorderAround LineStyle:=xlContinuous, ColorIndex:=5, Weight:=xlMedium
'End With
Else
With StartCell
.BorderAround LineStyle:=xlContinuous, ColorIndex:=3, Weight:=xlMedium
End With
With PostCell.Offset(fCounter, 0)
.BorderAround LineStyle:=xlContinuous, ColorIndex:=3, Weight:=xlMedium
End With
MsgBox "The parsed formulas do not equal the starting formula"
End If
Else
MsgBox "Not necessary to parse this formula"
End If
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
If Len(Parsed(2, 1)) > 0 Then
Application.Goto FirstParcedCell
End If
Else
'MsgBox "Multiple links in this cell inhibit this process"
End If
With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
.CalculateBeforeSave = True
.ScreenUpdating = True
.DisplayAlerts = True
End With
Exit Sub ' Must Exit Sub before Error Handling
If_Error:
With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
.ScreenUpdating = True
End With
Range("A1").Select
MsgBox "ALERT! " & Err.Number & " " + Err.Description & " [Worksheet " & ActiveSheet.Name _
& " Row: " & StartCell.Row & "]"
End Sub
2003/2007
Trying to consistently parse formula strings (Delimiter = any Opr sign) into i.e.
OprSigns = Array("+", "-", "*", "/", "^", ">", "<", "<>", ">=", "<=")
FormulaStr = "+123456789+'Summary 2-22-2007'!H8+'Summary 3-22-2007 '!H22- _
A1+(144/6)*'Summary 4-22-2007'!H23-B1+9876"
All formulas will begin (stuffed) with "+" sign if not already a "-" [if this makes parsing easier]
Goal:
Operator
Parsed(1) = 123456789 +
Parsed(2) = 'Summary 2-22-2007'!H8 +
Parsed(3) = 'Summary 3-22-2007'!H22 -
Parsed(4) = A1 +
Parsed(5) = (144/6) *
Parsed(6) = Summary 4-22-2007'H23 -
Parsed(7) = B1 +
Parsed(8) = 9876 end of FormulaStr
It is important to isolate, for later retrieval, each operator AFTER each Parsed(x)
Attempted (looooose VBA) Split(FormulaStr, OprSigns,1,1)
Another challenge, avoiding sign-look-a-like characters between each " ' " followed by " ' ! " or
in the Path to other workbooks (still within " ' " followed by " ' ! " I believe) Eg., would be
the "-" in dates like above.
The approach I tried was to avoid parsing between " ' " followed by " ' ! " as Gap(1), Gap(2), etc.
I can get very close but I need someone with much better VBA skills to get the gold ring.
Thanks for any thoughts, approaches or cuss words.
EagleOne
