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