How to Parse a string; Delimiter is any Operator

[EagleOne]

I appreciate the time and effort that you expended. Sincerely, I hope that we all have gained from
same.

EagleOne

the subroutine main was just a test driver to demostrate the code worked.
when working with cells functtions can only return one value. Somehow you
need to get it to return two values. In this case I would add another input
parameter to indicate if you want the left side or right side of the parse.

=Parse("*","L",String) or
=Parse("*","R",String)


Function Parse(ParseChar As String, ReturnHalf as String, String1 as String)

If StrComp(Left(String1, 1), ParseChar) = 0 Then
String1 = Mid(String1, 2)
End If

CharCount = 1
Do While StrComp(Mid(String1, CharCount, 1), ParseChar) <> 0

If StrComp(Mid(String1, CharCount, 1), "'") = 0 Then
CharCount = CharCount + 1
Do While Mid(String1, CharCount, 1) <> "'"
CharCount = CharCount + 1

Loop
End If
CharCount = CharCount + 1

Loop

if ReturnHalf = "R" Then
Parse = Mid(String1, CharCount + 1)
else
Parse = Left(String1, CharCount - 1)
end if
End Function

Joel,

Thanks so much for your time and knowledge.

I am in the midst of assimilating your code.
How can I use the code when the order/number of the operators is variable.
i.e. assume that I have only two cell ref's separated by the "/" operator.

Please do not take this as critical. This code will absolutely work for the hardcoded
StringA. How can I adapt the code for use on any formula cell?

EagleOne

I like these type problems


Sub main()

Dim StringA As String
Dim StringB As String

StringA = "+123456789+'Summary 2-22-2007'!H8+'Summary 3-22-2007
'!H22-A1+(144/6)*'Summary 4-22-2007'!H23-B1+9876"
StringB = ""
Call Parse("+", StringA, StringB)
StringA = StringB
Call Parse("+", StringA, StringB)
StringA = StringB
Call Parse("-", StringA, StringB)
StringA = StringB
Call Parse("+", StringA, StringB)
StringA = StringB
Call Parse("*", StringA, StringB)
StringA = StringB
Call Parse("-", StringA, StringB)
StringA = StringB
Call Parse("+", StringA, StringB)
End Sub
Sub Parse(ParseChar As String, ByRef String1, ByRef String2)

If StrComp(Left(String1, 1), ParseChar) = 0 Then
String1 = Mid(String1, 2)
End If

CharCount = 1
Do While StrComp(Mid(String1, CharCount, 1), ParseChar) <> 0

If StrComp(Mid(String1, CharCount, 1), "'") = 0 Then
CharCount = CharCount + 1
Do While Mid(String1, CharCount, 1) <> "'"
CharCount = CharCount + 1

Loop
End If
CharCount = CharCount + 1

Loop
String2 = Mid(String1, CharCount + 1)
String1 = Left(String1, CharCount - 1)
End Sub


:

Thanks for the time.

The dashes in dates are not being skipped but intentionally avoided by skipping over anything
between " ' " and " '! ".

Frankly it is a VBA issue if one has to program this parsing challenge, in VBA.


This isn't a VBA problem, it is a linear algebra problem with no real answer.
To get a unique answer your grammar must be defined better. Dashes are in
dates and are being skipped because of the single quotes. Rules like these
need to be defined.
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

 

[Ron Rosenfeld]

Yes you are correct. I did specify "following" Operators. As we all know, asking the correct
question leads to a best answer. I was not clear and/or not complete.

I should have asked about that. My oversight.

That said, "Houston - we have a solution!"

Glad it's working for you. Thanks for the feedback. Let me know if you run
into any more problems.

Thanks again Ron for your skill, knowledge and empathy for we NewBees.

I, too, benefit and learn by trying to do what you request. I, too, am self
taught so far as computers are concerned. And you're problem was interesting
to me -- took me a bit to figure out how to parse things they way you
requested. I'm still very much a newbie with regard to regular expressions.

--ron

 

[EagleOne]

Insite:

As you know, Excel is the prime S/W used in Corporate finance in "civilized" most countries.

With USA Sarbanes-Oxley or SOX (mandatory Financial Internal Controls with Big Teeth), documentation
of Excel worksheets is now a prime consulting driver. With your RE knowledge coupled with VBA and
your obvious ability to ascertain the shortest distance between two points, your future should be or
will be surrounded with success. BTY, I am very serious and not just patronizing you.

EagleOne

If I have any interface issues I'll post back.

Thanks

 

[EagleOne]

The following procedure parses formulas into cell references for documentation purposes.

It should work for most formulas except for grouped references (between parentheses)

Make sure that you have installed Microsoft VBScript Regular Expressions 5.5 a VBA library

This was all possible due to the help of Joel, Ron Rosenfeld and EagleOne. Thanks to all.



Sub ParseMultipleLinkFormulas()
'
' With help from Joel and Ron Rosenfeld 5-2-2007 EagleOne
'
'Note: Set a reference (Tools/References) to Microsoft VBScript Regular Expressions 5.5
'
'
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 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 ***********************************
If Application.VERSION = "12.0" Then
MaxRows = 1048576 - 1
MaxColumns = 16384 - 1
Else
MaxRows = 65536 - 1
MaxColumns = 256 - 1
End If
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)
On Error Resume Next
Range(Cells(1, myColumnsToProcess + 1), Cells(MaxRows, MaxColumns)).EntireColumn.Delete
Range(Cells(1, myColumnsToProcess + 1), Cells(65536, 256)).EntireColumn.Delete
On Error Resume Next
Range(Cells(myRowsToProcess + 1, 1), Cells(MaxRows, MaxColumns)).EntireRow.Delete
Range(Cells(myRowsToProcess + 1, 1), Cells(65536, 256)).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

'For fCount = 1 To UBound(Parsed)
' Debug.Print "Parsed(" & fCount&; ") = " & Parsed(fCount, 1), Parsed(fCount, 2)
'Next fCount
On Error Resume Next
If Len(Parsed(2, 1)) > 0 Then
If Error.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, 0)
.Formula = "=" & Parsed(fCounter, 1)
.NumberFormat = StartCell.NumberFormat
End With
AggregateFormula = AggregateFormula & PostCell.Offset(fCounter, 0).Address &
Parsed(fCounter, 2)
End If
Next fCounter
With PostCell.Offset(fCounter + 1, 0)
.Formula = AggregateFormula
.NumberFormat = StartCell.NumberFormat
End With
PostCell.Offset(fCounter + 1, 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 + 1, 0).Value Then
With StartCell
.Formula = "=" & PostCell.Offset(fCounter + 1, 0).Address
.BorderAround LineStyle:=xlContinuous, ColorIndex:=5, Weight:=xlMedium
End With
'With PostCell.Offset(fCounter + 1, 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 + 1, 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

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

 

[EagleOne]

In the code previously posted:

Change Error.Number to Err.Number

EagleOne

 

[EagleOne]

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