Testing for a cell being dependat on others?
Mike Piazza
formula cell are a reference to another cell? For example, whether a formula
is =55+17(not dependant) or =A7+B23(dependant on other cells??
Thansk for the help!
Jim Cone
I can't get a function to work, but the Formula Auditing toolbar
will trace dependents and precedent cells for you.
Not exactly what you wanted, but the following code may be of some help.
Regards,
Jim Cone
San Francisco, USA
'--------------------------------------------------------------------------------
' August 29, 2004 - Created by James Cone - San Francisco, USA
' Finds worksheet formulas on each sheet in the active workbook.
'Adds a new worksheet and lists all formulas found and their cell addresses,
' values, precedents and dependents.
' Formulas that have error values will also appear on the list.
' Calls MaxShtNum function
'--------------------------------------------------------------------------------
Sub FindFormulasRevised()
On Error GoTo ErrFindingFormulas
Dim objNewSht As Excel.Worksheet
Dim objAllShts As Excel.Sheets
Dim FormulaRange As Excel.Range
Dim FormulaCell As Excel.Range
Dim objGeneric As Excel.Range
Dim objCell As Excel.Range
Dim objSht As Object
Dim lngD As Long
Dim lngP As Long
Dim lngR As Long
Dim lngC As Long
Dim blnFound As Boolean
Const strMark As String = "!"
Application.ScreenUpdating = False
' Sheet selection is an event so...
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
lngC = MaxShtNum
Set objAllShts = ActiveWindow.SelectedSheets
Set objNewSht = Worksheets.Add(Before:=Sheets(1), Count:=1)
On Error Resume Next
objNewSht.Name = "Formula List " & lngC
On Error GoTo ErrFindingFormulas
lngR = 4
' Find all formulas on each worksheet.
For Each objSht In objAllShts
If objSht.ProtectContents Then
Application.DisplayAlerts = False
objNewSht.Delete
Application.ScreenUpdating = True
Application.Cursor = xlDefault
MsgBox objSht.Name & " sheet is protected. " & vbCr & _
"Unprotect the sheet and try again. ", vbExclamation, " Formula Map"
GoTo Exit_FindFormulas
End If
Application.StatusBar = "MAPPING SHEET " & objSht.Name
If TypeName(objSht) = "Worksheet" Then
objSht.Select 'Required
On Error Resume Next
Set FormulaRange = objSht.Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo ErrFindingFormulas
If Not FormulaRange Is Nothing Then
blnFound = True
objNewSht.Cells(lngR, 2).Value = objSht.Name
' Add cell address, cell formula and formula value to new sheet.
For Each FormulaCell In FormulaRange
' All but one of a merged group of cells are empty.
' If cell error, Value returns an error, Formula does not.
If Len(FormulaCell.Formula) Then
With objNewSht.Cells(lngR, 3)
.Value = FormulaCell.Address(False, False)
.Offset(0, 1).Value = "'" & FormulaCell.Formula
.Offset(0, 2).Value = FormulaCell.Value
If InStr(1, FormulaCell.Formula, strMark, vbTextCompare) > 0 Then
.Offset(0, -2).Interior.ColorIndex = 40
.Offset(0, -2).Value = strMark
End If
End With
On Error Resume Next
Set objGeneric = FormulaCell.Precedents
On Error GoTo ErrFindingFormulas
If Not objGeneric Is Nothing Then
If IsNull(objGeneric.MergeCells) Or objGeneric.MergeCells Then
lngP = 1
objNewSht.Cells(lngR, 6).Value = "Merged"
Else
lngP = objGeneric.Count
lngC = 0
' Add precedents to new sheet.
For Each objCell In objGeneric
With objNewSht.Cells(lngR + lngC, 6)
.Value = objCell.Address(False, False)
.Offset(0, 1).Value = objCell.Value
End With
lngC = lngC + 1
Next 'objCell
End If
Set objGeneric = Nothing
End If
On Error Resume Next
Set objGeneric = FormulaCell.Dependents
On Error GoTo ErrFindingFormulas
If Not objGeneric Is Nothing Then
If IsNull(objGeneric.MergeCells) Or objGeneric.MergeCells Then
lngD = 1
objNewSht.Cells(lngR, 6).Value = "Merged"
Else
lngD = objGeneric.Count
lngC = 0
' Add dependents to new sheet.
For Each objCell In objGeneric
With objNewSht.Cells(lngR + lngC, 8)
.Value = objCell.Address(False, False)
.Offset(0, 1).Value = objCell.Value
End With
lngC = lngC + 1
Next 'objCell
End If
Set objGeneric = Nothing
End If
' Make sure next row starts after last precedent/dependent.
lngR = lngR + WorksheetFunction.Max(lngP, lngD, 1)
lngP = 0
lngD = 0
End If 'Len(FormulaCell)
Next 'FormulaCell
objNewSht.Cells(lngR - 1, 2).Value = objSht.Name
Set FormulaRange = Nothing
End If 'Not FormulaRange is Nothing
End If 'TypeName Worksheet
Next 'objSht
If blnFound = False Then
Application.DisplayAlerts = False
objNewSht.Delete
Application.ScreenUpdating = True
Application.Cursor = xlDefault
MsgBox "No formulas were found. ", vbInformation, " Formula Map"
GoTo Exit_FindFormulas
End If
objNewSht.Activate
' Determine number of formulas found.
lngC = WorksheetFunction.CountA(objNewSht.Range(Cells(4, 3), Cells(lngR - 1, 3)))
' Make it look good.
With objNewSht.Range("B3:I3")
.Value = Array("Sheet Name", "Cell", "Formula ", "Value", "Precedents ", _
"Value", "Dependents ", "Value")
.Font.Bold = True
.Interior.ColorIndex = 40
.BorderAround LineStyle:=xlContinuous, Weight:=xlThin
End With
With objNewSht.Range("F3:I3")
.Interior.ColorIndex = 15
.BorderAround LineStyle:=xlContinuous, Weight:=xlThin
End With
objNewSht.Range("F3:G3").BorderAround LineStyle:=xlContinuous, Weight:=xlThin
With objNewSht.Range(objNewSht.Cells(4, 1), objNewSht.Cells(lngR, 1))
.HorizontalAlignment = xlHAlignCenter
With .Item(.Rows.Count + 2)
.Value = " Formula Map Release 1.0 - " & Format$(Date, "mm/dd/yy")
.Font.Size = 8
End With
End With
objNewSht.Range("E:E, G:G, I:I").HorizontalAlignment = xlLeft
objNewSht.Columns("A").ColumnWidth = 3
objNewSht.Columns("B:I").AutoFit
' After AutoFit
objNewSht.Range("B1").Value = lngC & " Formulas Found"
For lngC = 2 To 9
With objNewSht.Columns(lngC)
If .ColumnWidth > 30 Then .ColumnWidth = 30
End With
Next 'lngC
objNewSht.Range("A4").Select
ActiveWindow.FreezePanes = True
Exit_FindFormulas:
On Error Resume Next
Set objSht = Nothing
Set objCell = Nothing
Set objNewSht = Nothing
Set objAllShts = Nothing
Set objGeneric = Nothing
Set FormulaCell = Nothing
Set FormulaRange = Nothing
Application.StatusBar = False
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Exit Sub
ErrFindingFormulas:
Beep
Application.ScreenUpdating = True
MsgBox "Error " & Err.Number & " - " & Err.Description, vbCritical, " List Formulas"
Resume Exit_FindFormulas
End Sub
'-----------------------------------------------------------------
' MaxShtNum() Function
' May 05, 2001 - created by Jim Cone
' Returns a number between 0 and 100.
'-----------------------------------------------------------------
Function MaxShtNum() As Long
On Error GoTo BadSheet
Dim Sht As Object
Dim N As Double
For Each Sht In ActiveWorkbook.Sheets
N = WorksheetFunction.Max(N, Val(Right$(Sht.Name, 2)))
Next 'Sht
MaxShtNum = N + 1
Set Sht = Nothing
Exit Function
BadSheet:
MaxShtNum = 0
Set Sht = Nothing
End Function
'------------------------------------------------------------------
"Mike Piazza" <MikeP...@discussions.microsoft.com> wrote in message
news:8DFDFFD9-5251-4E47...@microsoft.com...
Rowan
whatever it is you want to do with the result:
Sub prec()
If Not shprec(ActiveCell) Then
Debug.Print False 'see result in immediate window
Else
Debug.Print True
End If
End Sub
Function shprec(cell As Range)
On Error GoTo noprec
cell.Precedents.Show
shprec = True
Exit Function
noprec:
shprec = False
End Function
Regards
Rowan