VBA to parse multiple links to one cell

[EagleOne]

2003/2007

Assume B3 formula is:
='3 Period Average EBITDA Summary'!H8*'_
3 Period Average EBITDA Summary'!H22/' _
3 Period Average EBITDA Summary'!H23 _
+5932

What series of VBA procedures would have to best
chance of correctly parsing the three links (or any three others)
so that blank cells in the same column i.e.
Cells(Rows.Count, SameColumn).End(xlUp)(2, 1) would end up

B5 formula ='3 Period Average EBITDA Summary'!H8
B6 formula ='3 Period Average EBITDA Summary'!H22
B7 formula ='3 Period Average EBITDA Summary'!H23
B8 formula = 5932

B10 = ((B5*B6)/B7)+5932

Then B3 is replaced with a link to B10 i.e.:
B3 formula =B10

My biggest concerns are properly identifying the complete formula
strings, the operators and properly handling any constants which may
appear anywhere in the original B3 formula.

Any, I mean ANY, even partial help, very much appreciated

EagleOne

 

[Don Guillett]

You may like this if all start with 3 for the sheet name
Sub ParseFormula()
With Range("b3")
p1 = InStr(.Formula, "3")
p2 = InStr(p1 + 1, .Formula, "3")
.Offset(2) = "='" & Mid(.Formula, p1, p2 - p1 - 2)
p3 = InStr(p2 + 1, .Formula, 3)
.Offset(3) = "='" & Mid(.Formula, p2, p3 - p2 - 2)
p4 = InStr(p3 + 1, .Formula, "+")
.Offset(4) = "='" & Mid(.Formula, p3, p4 - p3)
.Offset(5) = Mid(.Formula, p4 + 1, Len(.Formula) - p4)
'below is ONE line
.Offset(7).Formula = "=(" & .Offset(2) * .Offset(3) & ") / " & .Offset(4)
& "+" & .Offset(5)
End With
End Sub

 

[EagleOne]

Don,

Thanks for your reply.

In the example that I used, the sheets began similarily. Actually,
the sheets will not most likely be similar.

Later today I'll be able to test your thoughts.

First glance though, it appears that the Operators are hard-coded.

How would the VBA handle ANY Operator in any position? Or in short,
how could I best incorporate the following into your code?

OprSigns = Array("+", "-", "*", "/", "^", ">", "<", "<>", ">=",
"<=")
OprFirst = Len(ActiveCell.Formula)
For N = 0 To 9
OprTemp = InStr(1, ActiveCell.Formula, OprSigns(N),
vbTextCompare)
If OprTemp > 0 Then
If OprTemp < OprFirst Then OprFirst = OprTemp
End If
Next

Thanks again Don

EagleOne

 

[Don Guillett]

I worked on the example given. You have to be able to find something that
you know.
Other options would be more complicated and I fail to see why you want to
break it up anyway.
Sounds like a project.

 

[EagleOne]

Users have a tendancy to populate cells with multiple links, each of
which, should be in separate cells to permit an audit trail.

What I am attempting to do is parse those links so as to create that
audit trail.

As I said, my biggest concern was making sure that I was using the
best procedures to ID the formulas.

Thanks for your assistance!

EagleOne

 

[Don Guillett]

AFAIK, You would have to seach each CHARACTER of the string to find one of
the signs in the array.
something like
if character(i)=one of the signs, stop the for and identify where it was to
break up the string. Then the next, etc.

 

[Don Guillett]

or a for each math sign in a mid(i,1) loop

 

[EagleOne]

Thanks Don for your assistance

If anyone has any improvements, please post back

Sub ParseMultipleLinkFormulas()
'
Dim iCounter As Long
Dim sCounter As Long
Dim fCount As Long
Dim fLength As Long
Dim FirstLinkPosition As Long
Dim SecondLinkPosition As Long
Dim PreviousPosition As Long
Dim AnyParenthesis As Long
Dim OprSign() As String
Dim Parsed() As String
Dim AggregateFormula As String
Dim FormulaStr As String
Dim OprPosition() As Long
Dim StartCell As Range
FormulaStr = ActiveCell.Formula
fLength = Len(FormulaStr)
ReDim OprSign(1 To fLength) As String
ReDim OprPosition(1 To fLength) As Long
ReDim Parsed(1 To fLength) As String
OprSigns = Array("+", "-", "*", "/", "^", ">", "<", "<>", ">=", "<=")
FirstLinkPosition = InStr(1, FormulaStr, "'!")
SecondLinkPosition = InStr(FirstLinkPosition + 1, FormulaStr, "'!")
' Begins parsing only if there are two links in the formula and no
' grouping Parenthesis in the formulas
AnyParenthesis = InStr(1, FormulaStr, "(")
If SecondLinkPosition - FirstLinkPosition > 0 Then
If AnyParenthesis > 0 Then
MsgBox "Can not parse formulas due to Parenthesis Grouping"
End If
fCount = 0
PreviousPosition = 1
For iCounter = 1 To fLength Step 1
For sCounter = 0 To 9
If Mid(FormulaStr, iCounter, 1) = OprSigns(sCounter) Or iCounter = fLength Then
OprPosition(iCounter) = iCounter
OprSign(iCounter) = OprSigns(sCounter)
If fCount = 0 Then
Parsed(iCounter) = Mid(FormulaStr, PreviousPosition, _
IIf(iCounter > fLength, fLength, iCounter - 1))
Else
Parsed(iCounter) = "=" & Mid(FormulaStr, PreviousPosition + 1, _
iCounter - IIf(iCounter < fLength, PreviousPosition + 1, _
fLength - PreviousPosition))
End If
If iCounter = fLength Then
'Stop
Exit For
End If
fCount = fCount + 1
PreviousPosition = IIf(iCounter > fLength, fLength, iCounter)
End If
Next sCounter
Next iCounter
fCount = 0
Set StartCell = ActiveCell
AggregateFormula = "="
For iCounter = 1 To fLength Step 1
If Len(Parsed(iCounter)) > 0 Then
With StartCell.Offset(2 + fCount, 0)
.Formula = Parsed(iCounter)
.NumberFormat = StartCell.NumberFormat
End With
AggregateFormula = AggregateFormula & StartCell.Offset(2 + fCount, 0).Address & _
IIf(iCounter >= fLength, "", OprSign(iCounter))
fCount = fCount + 1
End If
Next iCounter
With StartCell.Offset(2 + fCount + 1, 0)
.Formula = AggregateFormula
.NumberFormat = StartCell.NumberFormat
End With
StartCell.Offset(2 + fCount + 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 = StartCell.Offset(2 + fCount + 1, 0).Value + 1 Then
With StartCell
.Formula = AggregateFormula
.BorderAround LineStyle:=xlContinuous, ColorIndex:=5, Weight:=xlMedium
End With
'With StartCell.Offset(2 + fCount + 1, 0)
' .BorderAround LineStyle:=xlContinuous, ColorIndex:=5, Weight:=xlMedium
'End With
Else
With StartCell
.BorderAround LineStyle:=xlContinuous, ColorIndex:=3, Weight:=xlMedium
End With
With StartCell.Offset(2 + fCount + 1, 0)
.BorderAround LineStyle:=xlContinuous, ColorIndex:=3, Weight:=xlMedium
End With
MsgBox "The parsed formulas do not equal the starting formula"
End If

End If

End Sub

 

[EagleOne]

As always, the betterment revision.

BTW, to use, Activate (Select) a cell with a formula cell
that has two or more links in the formula. Run the macro.

Sub ParseMultipleLinkFormulas()
'
' EagleOne 4-20-2007
'
Dim iCounter As Long
Dim sCounter As Long
Dim fCount As Long
Dim fLength As Long
Dim FirstLinkPosition As Long
Dim SecondLinkPosition As Long
Dim PreviousPosition As Long
Dim RParenthesis As Long
Dim LParenthesis As Long
Dim OprSign() As String
Dim Parsed() As String
Dim AggregateFormula As String
Dim FormulaStr As String
Dim OprPosition() As Long
Dim StartCell As Range
FormulaStr = ActiveCell.Formula
fLength = Len(FormulaStr)
ReDim OprSign(1 To fLength) As String
ReDim OprPosition(1 To fLength) As Long
ReDim Parsed(1 To fLength) As String
OprSigns = Array("+", "-", "*", "/", "^", ">", "<", "<>", ">=", "<=")
FirstLinkPosition = InStr(1, FormulaStr, "'!")
SecondLinkPosition = InStr(FirstLinkPosition + 1, FormulaStr, "'!")
'
' Begins parsing only if there are two links in the formula
' Grouping Parantheses in formula may stop ihe process
'
LParenthesis = InStr(1, FormulaStr, "(")
If SecondLinkPosition - FirstLinkPosition > 0 Then
fCount = 0
PreviousPosition = 1
For iCounter = 1 To fLength Step 1
For sCounter = 0 To 9
If Mid(FormulaStr, iCounter, 1) = OprSigns(sCounter) Or iCounter = fLength Then
OprPosition(iCounter) = iCounter
OprSign(iCounter) = OprSigns(sCounter)
If fCount = 0 Then
Parsed(iCounter) = Mid(FormulaStr, PreviousPosition, _
IIf(iCounter > fLength, fLength, iCounter - 1))
Else
Parsed(iCounter) = "=" & Mid(FormulaStr, PreviousPosition + 1, _
iCounter - IIf(iCounter < fLength, PreviousPosition + 1, _
fLength - PreviousPosition))
End If
LParenthesis = InStr(PreviousPosition, Parsed(iCounter), "(")
RParenthesis = InStr(PreviousPosition, Mid(FormulaStr, _
PreviousPosition, fLength + 1 - PreviousPosition), ")")
If RParenthesis > PreviousPosition + Len(Parsed(iCounter)) Then
MsgBox "Can not parse formulas due to Parenthesis Grouping"
Exit Sub
End If
If iCounter = fLength Then
Exit For
End If
fCount = fCount + 1
PreviousPosition = IIf(iCounter > fLength, fLength, iCounter)
End If
Next sCounter
Next iCounter
fCount = 0
Set StartCell = ActiveCell
AggregateFormula = "="
For iCounter = 1 To fLength Step 1
If Len(Parsed(iCounter)) > 0 Then
With StartCell.Offset(2 + fCount, 0)
.Formula = Parsed(iCounter)
.NumberFormat = StartCell.NumberFormat
End With
AggregateFormula = AggregateFormula & StartCell.Offset(2 + fCount, 0).Address & _
IIf(iCounter >= fLength, "", OprSign(iCounter))
fCount = fCount + 1
End If
Next iCounter
With StartCell.Offset(2 + fCount + 1, 0)
.Formula = AggregateFormula
.NumberFormat = StartCell.NumberFormat
End With
StartCell.Offset(2 + fCount + 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 = StartCell.Offset(2 + fCount + 1, 0).Value Then
With StartCell
.Formula = "=" & StartCell.Offset(2 + fCount + 1, 0).Address
.BorderAround LineStyle:=xlContinuous, ColorIndex:=5, Weight:=xlMedium
End With
Else
With StartCell
.BorderAround LineStyle:=xlContinuous, ColorIndex:=3, Weight:=xlMedium
End With
With StartCell.Offset(2 + fCount + 1, 0)
.BorderAround LineStyle:=xlContinuous, ColorIndex:=3, Weight:=xlMedium
End With
MsgBox "The parsed formulas do not equal the starting formula"
End If

End If

End Sub