Forgot the code:
Ron,
Here is what I came up with. Any thoughts for improvement appreciated.
****************************
Sub ExtractFormulaConstants()
Dim X As String, Z As String
Dim Y As Variant, Signs As Variant
Dim Ndx As Long
Signs = Array("=", "(", ")", "+", "-", "*", "/")
X = Range("A1").Formula
Z = ""
For Ndx = LBound(Signs) To UBound(Signs) Step 1
X = Replace(X, Signs(Ndx), "~")
Next
Y = Split(X, "~")
For Ndx = LBound(Y) To UBound(Y) Step 1
If IsNumeric(Y(Ndx)) Then
Z = Z & Y(Ndx) & "~"
End If
Next
If Right(Z, 1) = "~" Then
Z = Left(Z, Len(Z) - 1)
End If
Y = Split(Z, "~")
ActiveSheet.Range("G1:G" & UBound(Y) + 1).Resize(UBound(Y) + 1) = Split(Z, "~")
For Ndx = LBound(Y) To UBound(Y) Step 1
Range("G" & Ndx + 1).Value = Y(Ndx)
Next
MsgBox "Process Completed! Press OK to Continue"
End Sub
****************************
For testing, the "formula" I used in "A1":
=687319+523187-7344000+758450+2232642+1995819-2721538+1491693+723564+(C1*3)
My results are:
687319~523187~7344000~758450~2232642~1995819~2721538~1491693~723564~3
Because I changed the operational signs to "~" I have lost positive vs negative numbers.
Can you think of a way to preserve the positive vs negative numbers?
EagleOne
If you want to treat the "-" as part of the number when it precedes a number,
as opposed to treating it as an operator, then
Using your approach, you could first
Replace all the "-" with "+-"
and then remove "-" from your list of signs.
Here's a routine that uses regular expressions to do the same thing. It will
work on your sample data. However, it would need to be extended to take care
of the worksheet function issue I raised earlier.
In order for this to run, from the VBA Editor top menu, select
Tools/References
Select: Microsoft VBScript Regular Expressions 5.5
=========================================
Option Explicit
Sub ParseFormula()
Dim FormConstants()
Dim FormulaText As String
Dim Pattern As String
Dim CellRef As String
Dim Operator As String
Dim Ignore As String
Dim NumConstant As String
Dim i As Long
Operator = "[/*^&()=<>,]"
CellRef = "\$?[A-Z]{1,2}\$?\d{1,5}"
Ignore = "(" & Operator & "|" & CellRef & ")"
NumConstant = "-?(\d*\.)?\d+"
FormulaText = Selection.Formula
FormulaText = RESub(FormulaText, Ignore, "~")
ReDim FormConstants(1 To RECount(FormulaText, NumConstant))
For i = 1 To UBound(FormConstants)
FormConstants(i) = REMid(FormulaText, NumConstant, i)
Next i
For i = 1 To UBound(FormConstants)
Selection.Offset(0, i) = FormConstants(i)
Next i
End Sub
'------------------------------
Function REMid(str As String, Pattern As String, _
Optional Index As Variant = 1, _
Optional CaseSensitive As Boolean = True) _
As Variant 'Variant as value may be string or array
Dim objRegExp As RegExp
Dim objMatch As Match
Dim colMatches As MatchCollection
Dim i As Long 'counter
Dim t() As String 'container for array results
' Create a regular expression object.
Set objRegExp = New RegExp
'Set the pattern by using the Pattern property.
objRegExp.Pattern = Pattern
' Set Case Insensitivity.
objRegExp.IgnoreCase = Not CaseSensitive
'Set global applicability.
objRegExp.Global = True
'Test whether the String can be compared.
If (objRegExp.Test(str) = True) Then
'Get the matches.
Set colMatches = objRegExp.Execute(str) ' Execute search.
On Error Resume Next 'return null string if a colmatch index is non-existent
If IsArray(Index) Then
ReDim t(1 To UBound(Index))
For i = 1 To UBound(Index)
t(i) = colMatches(Index(i) - 1)
Next i
REMid = t()
Else
REMid = CStr(colMatches(Index - 1))
If IsEmpty(REMid) Then REMid = ""
End If
On Error GoTo 0 'reset error handler
Else
REMid = ""
End If
End Function
'-------------------------------
Function RECount(str As String, Pattern As String, _
Optional CaseSensitive As Boolean = True) As Long
Dim objRegExp As RegExp
Dim objMatch As Match
Dim colMatches As MatchCollection
' Create a regular expression object.
Set objRegExp = New RegExp
'Set the pattern by using the Pattern property.
objRegExp.Pattern = Pattern
' Set Case Insensitivity.
objRegExp.IgnoreCase = Not CaseSensitive
'Set global applicability.
objRegExp.Global = True
'Test whether the String can be compared.
If (objRegExp.Test(str) = True) Then
'Get the matches.
Set colMatches = objRegExp.Execute(str) ' Execute search.
RECount = colMatches.Count
Else
RECount = 0
End If
End Function
'--------------------------
Function RESub(str As String, Pattern As String, _
Optional NewText As String = "", _
Optional Index As Variant = 1, _
Optional CaseSensitive As Boolean = True) _
As Variant 'Variant as value may be string or array
Dim objRegExp As RegExp
Dim objMatch As Match
Dim colMatches As MatchCollection
Dim i As Long 'counter
Dim t() As String 'container for array results
' Create a regular expression object.
Set objRegExp = New RegExp
'Set the pattern by using the Pattern property.
objRegExp.Pattern = Pattern
' Set Case Insensitivity.
objRegExp.IgnoreCase = Not CaseSensitive
'Set global applicability.
objRegExp.Global = True
RESub = objRegExp.Replace(str, NewText)
End Function
'=========================================
--ron
