Mr. Deeds
See below.
Jim Cone
' ---------------------------------------
' August 29, 2004 - Created by James Cone - San Francisco, USA
' Finds worksheet formulas on each sheet in workbook. 'Adds a new worksheet and lists
' all formulas found and their cell addresses, values and precedents.
' Formulas that have error values in the formula will also appear on the list.
' Formulas that contain references to other sheets are marked with a "!" in column A.
' Calls MaxShtNum function.
' September 06, 2004 - Added dependents.
' October 08, 2004 - Added blnFound variable and MsgBox.
' December 09, 2004 - Added check for merged cells.
' ---------------------------------------
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
'----------------------------
"Deeds" <
[email protected]>
wrote in message
I am using the Aug 29, 2004 version...how do I get at a newer version?
Thanks
