I
Ilia
Hi everyone,
I'm making a macro for some coworkers that will process a particular cell
and nest all formulas in other cells addressed into a target cell. I am
wondering if someone could take some time to help me test this. Code
apprears below. It has the following features:
* will process any cell that contains a reference to another cell in its
formula
* will leave formulas as they are if they do not contain cell references
* will leave references to cells containing constants
* will leave range references as they are
* will ignore anything between double quotation marks
The following shortcomings that I'm aware of so far:
* does not contain any sophisticated error handling
* does not do well with ROW(), COLUMN(), etc that point to cell references
containing formulas, e.g. you'll get =ROW(ROUND(A2,2))
* has not been tested with array formulas
* does not take into account limitations of function nesting or total
formula length
* makes a large number of recursive calls to RegExp procedure and may be
slow for longer dependency trees
To use this, place it in a standard module and run macro called
makeMegaFormula. The VB project must include a reference to Microsoft
VBScript Regular Expressions 1.0 due to early binding technique used.
This is the code. Again, I welcome all comments, bugs, and suggestions.
Option Explicit
Public Sub makeMegaFormula()
Dim rngSource As Excel.Range
Dim rngTarget As Excel.Range
Dim megaFormula As String
On Error Resume Next
Set rngSource = Application.InputBox( _
Prompt:="Select source cell:", _
Type:=8)
Set rngTarget = Application.InputBox( _
Prompt:="Select target cell:", _
Type:=8)
On Error GoTo 0
If (rngSource Is Nothing) Or (rngTarget Is Nothing) Then
Exit Sub
End If
megaFormula = extractAddress(rngSource)
Call MsgBox("Megaformula is: " & vbCrLf & megaFormula)
rngTarget.formula = "=" & megaFormula
End Sub
Private Function extractAddress(ByVal rng As Excel.Range) _
As String
Static inQuotes As Boolean
Static recursionLevel As Long
Dim parseString As String, tempString As String
Dim addressLength As Long, parsePosition As Long
Dim rangeLength As Long
Dim cursor As Long
Dim returnValue As String
Dim formulaString As String
If (rng.HasFormula) Then
formulaString = Right$(rng.formula, _
Len(rng.formula) - 1)
Else
Exit Function
End If
Debug.Print rng.address & " has a formula: " & rng.formula
If Not hasReference(rng) Then
'no references in range, exiting
extractAddress = formulaString
Exit Function
End If
For cursor = 1 To Len(formulaString)
parseString = Mid$(formulaString, cursor, 11)
If (Left$(parseString, 1) = Chr(34)) Then
inQuotes = Not inQuotes
End If
If Not inQuotes Then
addressLength = 0
For parsePosition = 2 To 11
If isAddress(Left$(parseString, parsePosition)) Then
addressLength = parsePosition
End If
Next parsePosition
If Mid$(parseString, addressLength + 1, 1) = ":" Then
'we have a range on our hands
parseString = Mid$(formulaString, cursor, 23)
Debug.Print "Processing range in " & parseString
For parsePosition = 2 To 11
If isAddress(Mid(parseString, _
addressLength + 2, _
parsePosition)) Then
rangeLength = addressLength + _
parsePosition + 2
End If
Next parsePosition
returnValue = returnValue & _
Left$(parseString, rangeLength)
cursor = cursor + rangeLength - 1
ElseIf addressLength > 0 Then
tempString = extractAddress(rng.Parent.Range( _
Left$(parseString, addressLength)))
DoEvents
If (Len(tempString) = 0) Then
tempString = Left$(parseString, addressLength)
End If
returnValue = returnValue & "(" & _
tempString & ")"
cursor = cursor + addressLength - 1
Else
returnValue = returnValue & Left$(parseString, 1)
End If
Else
returnValue = returnValue & Left$(parseString, 1)
End If
Next cursor
extractAddress = returnValue
End Function
Public Function hasReference(ByVal rng As Range) _
As Boolean
If Not rng.HasFormula Then Exit Function
If isAddress(rng.formula, False) Then
hasReference = True
End If
End Function
Public Function isAddress(strTest As String, _
Optional wholestring As Boolean = True) _
As Boolean
Dim re As VBScript_RegExp_10.RegExp
Dim strPattern As String
Set re = New VBScript_RegExp_10.RegExp
If (wholestring) Then strPattern = strPattern & "^"
strPattern = strPattern & _
"[\$]{0,1}[A-Z]{1,3}[\$]{0,1}[1-9][0-9]{0,6}"
If (wholestring) Then strPattern = strPattern & "$"
re.Pattern = strPattern
re.IgnoreCase = True
isAddress = re.Test(strTest)
End Function
I'm making a macro for some coworkers that will process a particular cell
and nest all formulas in other cells addressed into a target cell. I am
wondering if someone could take some time to help me test this. Code
apprears below. It has the following features:
* will process any cell that contains a reference to another cell in its
formula
* will leave formulas as they are if they do not contain cell references
* will leave references to cells containing constants
* will leave range references as they are
* will ignore anything between double quotation marks
The following shortcomings that I'm aware of so far:
* does not contain any sophisticated error handling
* does not do well with ROW(), COLUMN(), etc that point to cell references
containing formulas, e.g. you'll get =ROW(ROUND(A2,2))
* has not been tested with array formulas
* does not take into account limitations of function nesting or total
formula length
* makes a large number of recursive calls to RegExp procedure and may be
slow for longer dependency trees
To use this, place it in a standard module and run macro called
makeMegaFormula. The VB project must include a reference to Microsoft
VBScript Regular Expressions 1.0 due to early binding technique used.
This is the code. Again, I welcome all comments, bugs, and suggestions.
Option Explicit
Public Sub makeMegaFormula()
Dim rngSource As Excel.Range
Dim rngTarget As Excel.Range
Dim megaFormula As String
On Error Resume Next
Set rngSource = Application.InputBox( _
Prompt:="Select source cell:", _
Type:=8)
Set rngTarget = Application.InputBox( _
Prompt:="Select target cell:", _
Type:=8)
On Error GoTo 0
If (rngSource Is Nothing) Or (rngTarget Is Nothing) Then
Exit Sub
End If
megaFormula = extractAddress(rngSource)
Call MsgBox("Megaformula is: " & vbCrLf & megaFormula)
rngTarget.formula = "=" & megaFormula
End Sub
Private Function extractAddress(ByVal rng As Excel.Range) _
As String
Static inQuotes As Boolean
Static recursionLevel As Long
Dim parseString As String, tempString As String
Dim addressLength As Long, parsePosition As Long
Dim rangeLength As Long
Dim cursor As Long
Dim returnValue As String
Dim formulaString As String
If (rng.HasFormula) Then
formulaString = Right$(rng.formula, _
Len(rng.formula) - 1)
Else
Exit Function
End If
Debug.Print rng.address & " has a formula: " & rng.formula
If Not hasReference(rng) Then
'no references in range, exiting
extractAddress = formulaString
Exit Function
End If
For cursor = 1 To Len(formulaString)
parseString = Mid$(formulaString, cursor, 11)
If (Left$(parseString, 1) = Chr(34)) Then
inQuotes = Not inQuotes
End If
If Not inQuotes Then
addressLength = 0
For parsePosition = 2 To 11
If isAddress(Left$(parseString, parsePosition)) Then
addressLength = parsePosition
End If
Next parsePosition
If Mid$(parseString, addressLength + 1, 1) = ":" Then
'we have a range on our hands
parseString = Mid$(formulaString, cursor, 23)
Debug.Print "Processing range in " & parseString
For parsePosition = 2 To 11
If isAddress(Mid(parseString, _
addressLength + 2, _
parsePosition)) Then
rangeLength = addressLength + _
parsePosition + 2
End If
Next parsePosition
returnValue = returnValue & _
Left$(parseString, rangeLength)
cursor = cursor + rangeLength - 1
ElseIf addressLength > 0 Then
tempString = extractAddress(rng.Parent.Range( _
Left$(parseString, addressLength)))
DoEvents
If (Len(tempString) = 0) Then
tempString = Left$(parseString, addressLength)
End If
returnValue = returnValue & "(" & _
tempString & ")"
cursor = cursor + addressLength - 1
Else
returnValue = returnValue & Left$(parseString, 1)
End If
Else
returnValue = returnValue & Left$(parseString, 1)
End If
Next cursor
extractAddress = returnValue
End Function
Public Function hasReference(ByVal rng As Range) _
As Boolean
If Not rng.HasFormula Then Exit Function
If isAddress(rng.formula, False) Then
hasReference = True
End If
End Function
Public Function isAddress(strTest As String, _
Optional wholestring As Boolean = True) _
As Boolean
Dim re As VBScript_RegExp_10.RegExp
Dim strPattern As String
Set re = New VBScript_RegExp_10.RegExp
If (wholestring) Then strPattern = strPattern & "^"
strPattern = strPattern & _
"[\$]{0,1}[A-Z]{1,3}[\$]{0,1}[1-9][0-9]{0,6}"
If (wholestring) Then strPattern = strPattern & "$"
re.Pattern = strPattern
re.IgnoreCase = True
isAddress = re.Test(strTest)
End Function