'Attribute VB_Name = "McRitchie_ListFSubs"
Option Explicit
Sub ListFunctionsAndSubs()
'Documented in  http://www.mvps.org/dmcritchie/excel/buildtoc.htm
'Coding:  http://www.mvps.org/dmcritchie/excel/code/listfsubs.txt
'Coding:  http://www.mvps.org/dmcritchie/excel/code/buildtoc.txt
'Coding:  http://www.mvps.org/dmcritchie/excel/code/gotostuff.txt
'My Excel Macros: http://www.mvps.org/dmcritchie/excel/excel.htm
'basis of coding Chip Pearson   posted  1999-09-07
'  in thread: http://groups.google.com/groups?th=ee903e5e5bea69a1
'process all open workbooks & corr. code 1999-09-07 Bernie Deitrick
'cosmetic changes and sort 1999-09-08 David McRitchie
'code correction/enhanced for use with GoToSub

'since I don't have password protected workbooks you may have
'to work in some code like:
'   For Each myBook In Application.Workbooks
'     If Application.VBE.ActiveVBProject.Protection = vbext_pp_none Then


Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual          'in XL97

'You must have references enabled to the VBE to use this code.
'From the Tools menu (in the VBA Editor, not Excel), select References,
'and check "Microsoft Visual Basic For Application Extensibility".

Dim myBook As Workbook
Dim iAnswer As Long
Dim myType As String

Dim myStartLine As Long
Dim NumLines As Long

Dim ProcName As String
Dim VBComp As VBComponent
Dim RowNdx As Long

Cells(1, 1) = "Book"
Cells(1, 2) = "Module"
Cells(1, 3) = "Name"
Cells(1, 4) = "Type"
Cells(1, 5) = "Beg#"
Cells(1, 6) = "Lns"
Cells(1, 7) = "###"
Cells(1, 8) = "chk"
Cells(1, 9) = "Locate Macro using GoToSub"
Rows("1:1").FONT.Bold = True
Rows("1:1").FONT.Underline = xlUnderlineStyleSingle
Columns("G:H").FONT.ColorIndex = 41
Columns("H:H").FONT.Bold = True
Columns("i:i").FONT.ColorIndex = 7

RowNdx = 2
For Each myBook In Application.Workbooks
For Each VBComp In myBook.VBProject.VBComponents
    If VBComp.Type = vbext_ct_StdModule Then
        NumLines = 0
        With VBComp.CodeModule
            myStartLine = .CountOfDeclarationLines + 1
            While myStartLine <= .CountOfLines
                ProcName = .ProcOfLine(myStartLine, vbext_pk_Proc)
                Cells(RowNdx, 1).Value = myBook.Name
                Cells(RowNdx, 2).Value = VBComp.Name
                Cells(RowNdx, 3).Value = ProcName
                Cells(RowNdx, 5).Value = myStartLine
                NumLines = .ProcCountLines(ProcName, vbext_pk_Proc)
                Cells(RowNdx, 6).Value = NumLines
                Cells(RowNdx, 7).Value = RowNdx - 1
                'The following is useful with macro GoToSub
                Cells(RowNdx, 9).Value = myBook.Name & "!" & ProcName

DetermineType:

                If .Find("Function", myStartLine, 1, myStartLine, 200, _
                   True, False, False) Then
                     myType = "Function"
                ElseIf .Find("Sub", myStartLine, 1, myStartLine, 200, _
                    True, False, False) Then
                     myType = "SubRoutine"
             '   Else: myStartLine = myStartLine + 1
             '   NumLines = NumLines - 1
             '   GoTo DetermineType:
                End If

                Cells(RowNdx, 4).Value = myType
                myStartLine = myStartLine + _
                  .ProcCountLines(.ProcOfLine(myStartLine, _
                    vbext_pk_Proc), vbext_pk_Proc)

                RowNdx = RowNdx + 1
            Wend   'myStartLine
        End With
    End If

Next VBComp
Next myBook

Range("H2").FormulaR1C1 = "=IF(COUNTIF(C[-5],RC[-5])>1,""Dup"","""")"
Range("H2").AutoFill Destination:=Range("H2:H" & RowNdx - 1)
Columns("A:H").EntireColumn.AutoFit
Range("A1").Select

'Make results visible including duplicates before asking about sort...
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

iAnswer = MsgBox(RowNdx - 2 & " Entires. Would you like to sort them, by Name?", vbOKCancel, "Option to Sort")
Application.ScreenUpdating = False
If iAnswer = vbOK Then
    Selection.Sort Key1:=Range("C2"), Order1:=xlAscending, Key2:=Range("A2") _
        , Order2:=xlAscending, Key3:=Range("B2"), Order3:=xlAscending, Header:= _
        xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End If
End Sub