Determining formula reference type
 

I am attempting to write a function to test if any copied formulas
contains a reference to a cell outside of the copied range. If any of
the cells in the formula is outside of the copied range, then I flag
the formula as an error.

I have one significant issue:

1) If all the cells in the formula are absolute references (either
named cell or using $), then even if they are outside of the copied
range, the formula is valid. I cannot determine if the individual
cells are absolute or relative references. Any ideas?

I have attached my current routine. It has a some basic techniques
for parsing formulas that may be of interest to some.


Public Sub TestPastedFormulas(blnOnlyWarning As Boolean,
blnShowMessage As Boolean, intErrCol As Integer, intErrNum As Integer)

Dim rngPasteCells As Excel.Range
Dim c As Excel.Range
Dim p As Excel.Range
Dim cell As Excel.Range
Dim PasteSelection As Excel.Range
Dim blnShowWarning As Boolean
Dim msg As String

Dim SaveEE As Boolean
Dim SaveSU As Boolean

With Application
SaveSU = .ScreenUpdating
SaveEE = .EnableEvents
.EnableEvents = False
.ScreenUpdating = False
End With
blnShowWarning = False

Set rngPasteCells = Nothing
Set PasteSelection = Selection

If Selection.Cells.Count = 1 Then
Set rngPasteCells = Selection
Else
On Error Resume Next
Set rngPasteCells = Selection.SpecialCells(xlCellTypeFormulas)
End If

If rngPasteCells Is Nothing Then GoTo CommonExit
On Error GoTo 0

'Debug.Print rngPasteCells.Address



For Each c In rngPasteCells
Set p = Nothing
Debug.Print "Cell Row: " & c.Row & " Column: " & c.Column & "
has formulas: " & c.Formula
Debug.Print "Cell Row: " & c.Row & " Column: " & c.Column & "
has value: " & c.Value
If c.HasFormula Then

'-- Only test cells that are not locked (the ones
estimator can change).
If Not c.Locked Then


On Error Resume Next
Set p = c.DirectPrecedents
On Error GoTo 0
If Not p Is Nothing Then
For Each cell In p
Debug.Print c.Address; "-- "; cell.Address
Debug.Print c.Formula

If Intersect(cell, PasteSelection) Is Nothing
Then
'-- Cell reference is outside of the range
- hightlight cell and show warning.
GoSub FlagCellAsError
End If
Next

'-- At this point the cell has precedents which
are seem to be valid, but
'-- we still maybe have a reference to another
sheet
'-- if the formula contains '! this is most
likely a reference to another
'-- sheet.
If InStr(1, c.Formula, "!") = 1 Then
'Stop
GoSub FlagCellAsError
End If
Else
'-- There is a formula - but no precedents on
sheet (as returned by c.DirectPrecedents)
'-- This means it is a simple formula (ie =4*6) or
the precedents are in a different
'-- worksheet or workbook. Our test will be to
see if there is a "!" in the formula. This
'-- means it is on a different sheet.
If InStr(1, c.Formula, "!") = 1 Then
'Stop
GoSub FlagCellAsError
End If
End If
End If

End If
Next c

If blnShowWarning And blnShowMessage Then
'-- Show warning message
Application.ScreenUpdating = True
msg = "You have performed a Copy/Paste or Get command and have
pasted lines containing formulas that may now be incorrect." & vbLf &
vbLf _
& "The formulas contain references to cells that were NOT
copied. This means they are currently pointing to cells that may have
a different defintion than in the original location." & vbLf & vbLf

If blnOnlyWarning Then
msg = msg & "The lines have been flagged as temporary
errors and the formulas appear in bold orange font. You must check to
ensure these formulas are still valid."
Else
msg = msg & "The lines have been flagged as errors and the
formulas appear as text. You must check to ensure these formulas are
still valid (Use F2 key to edit and correct)."
End If
MsgBox msg, vbExclamation, "BEST Estimating - Formula Waring"
Application.ScreenUpdating = False
End If

CommonExit:
With Application
.EnableEvents = SaveEE
.ScreenUpdating = SaveSU
End With
Exit Sub

FlagCellAsError:

'Debug.Print "The formula cell is OUTSIDE of paste range"
blnShowWarning = True

If blnOnlyWarning Then
c.Font.Color = vbRed
c.NumberFormat = "@" '-- Turn to Text
c.Formula = c.Formula
Else
c.Font.Color = vbRed
c.NumberFormat = "@" '-- Turn to Text
c.Formula = c.Formula
End If

If intErrCol = 0 Then intErrCol = ExtractHeaderCol("*ERROR1", 1)
If intErrNum = 0 Then intErrNum = 1401
If intErrCol 0 Then Cells(c.Row, intErrCol).Value = intErrNum
'-- Standard Error number.
Return


End Sub