'Current is no longer on geocities -- this is probably old material-- http://www.geocities.com/davemcritchie/excel/buildtoc.htm
'My Excel Macros: http://www.geocities.com/davemcritchie/excel/excel.htm
[site changed Nov. 2001 to  http://www.mvps.org/dmcritchie/excel/excel.htm]

Sub DelHyperLinks()
  Selection.Hyperlinks.Delete
End Sub

Sub MakeHyperlinks()
  Dim cell As Range
  For Each cell In Selection
    With Worksheets(1)
       .Hyperlinks.Add Anchor:=cell, _
        Address:=cell.Value, _
        ScreenTip:=cell.Value, _
        TextToDisplay:=cell.Value
     End With
  Next cell
End Sub

Sub GoToSub()
   'Display Subroutine or Function named in selected cell
   'David McRitchie 1999-11-12 rev. 2000-04-13
   'http://www.geocities.com/davemcritchie/excel/buildtoc.htm
   On Error GoTo notfound   'formerly named GoToSubroutine
   Dim i As Long
   Application.Goto Reference:=ActiveCell.Value
   Exit Sub
notfound:   '<font color="green">new material
   On Error GoTo notfound2
   If Left(ActiveCell.Formula, 1) = "=" Then
      For i = 1 To Len(ActiveCell.Formula)
        If Mid(ActiveCell.Formula, i, 1) = "(" Then
          Application.Goto Reference:=Mid(ActiveCell.Formula, 2, i - 2)
          Exit Sub
        End If
      Next i
      MsgBox Mid(ActiveCell.Formula, 2, i - 2) _
        & "was not found as a User Defined Function, " _
        & "verify with Paste Function Wizard [fx]"
   End If
notfound2:  '</font>end of new material
   On Error Resume Next
   MsgBox "Procedure or Function " & ActiveCell.Value _
      & " is not available, try ALT+F8 to find Sub, or [fx] to find UDF"
End Sub

Sub BuildTOC()
  'listed from active cell down 3-cols --  DMcRitchie 1999-08-14 1999-09-01
  Dim iSheet As Long, iBefore As Long
  Dim sSheetName As String
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  cRow = ActiveCell.Row
  cCol = ActiveCell.Column
  sSheetName = UCase(ActiveSheet.Name)
  sActiveCell = UCase(ActiveCell.Value)
  mg = ""
  CRLF = Chr(10)  'Actually just CR
  Set rg = Range(Cells(cRow, cCol), Cells(cRow - 1 + ActiveWorkbook.Sheets.Count, cCol + 2))
  rg.Select
  If sSheetName <> "$$TOC" Then mg = mg & "Sheetname is not $$TOC" & CRLF
  If sActiveCell <> "$$TOC" Then mg = mg & "Selected cell value is not $$TOC" & CRLF
  If mg <> "" Then
     mg = "Warning BuildTOC will destructively rewrite the selected area" _
     & CRLF & CRLF & mg & CRLF & "Press OK to proceed, " _
      & "the affected area will be rewritten, or" & CRLF & _
      "Press CANCEL to check area then reinvoke this macro (BuildTOC)"
     Application.ScreenUpdating = True  'make range visible
     Reply = MsgBox(mg, vbOKCancel, "Create TOC for " & ActiveWorkbook.Sheets.Count _
      & " items in workbook")
     Application.ScreenUpdating = False
     If Reply <> 1 Then GoTo AbortCode
  End If
  rg.Clear      'Clear out any previous hyperlinks, fonts, etc in the area
  For csht = 1 To ActiveWorkbook.Sheets.Count
     If TypeName(Sheets(csht)) = "Worksheet" Then
        'hypName = "'" & Sheets(csht).Name
        If Application.Version < "8.0" Then
          '-- use next line for XL95
          Cells(cRow - 1 + csht, cCol + 2) = "'" & Sheets(csht).Name  'XL95
        Else
          '-- Only for XL97, XL98, XL2000 -- will create hyperlink & codename
          Cells(cRow - 1 + csht, cCol + 2) = "'" & Sheets(csht).CodeName
          ActiveSheet.Hyperlinks.Add Anchor:=Cells(cRow - 1 + csht, cCol), _
            Address:="", SubAddress:="'" & Sheets(csht).Name & "'!A1"
        End If
     Else
       Cells(cRow - 1 + csht, cCol) = "'" & Sheets(csht).Name
       Cells(cRow - 1 + csht, cCol + 2) = "'" & Sheets(csht).Name
     End If
     Cells(cRow - 1 + csht, cCol) = "'" & Sheets(csht).Name
     Cells(cRow - 1 + csht, cCol + 1) = TypeName(Sheets(csht))
    '-- include next line if you want to see cell A1 for each sheet
     Cells(cRow - 1 + csht, cCol + 3) = Sheets(Sheets(csht).Name).Range("A1").Value
  Next csht

  'Now sort the results:  2. Type(D), 1. Name (A), 3. module(unsorted)
  rg.Sort Key1:=rg.Cells(1, 2), Order1:=xlDescending, Key2:=rg.Cells(1, 1) _
      , Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
      Orientation:=xlTopToBottom
  rg.Columns.AutoFit
  rg.Select           'optional
  'if cells above range are blank want these headers
  ' Worksheet,   Type,    codename
  If cRow > 1 Then
     If "" = Trim(Cells(cRow - 1, cCol) & Cells(cRow - 1, cCol + 1) & Cells(cRow - 1, cCol + 2)) Then
        Cells(cRow - 1, cCol) = "Worksheet"
        Cells(cRow - 1, cCol + 1) = "Type"
        Cells(cRow - 1, cCol + 2) = "CodeName"
     End If
  End If
  Application.ScreenUpdating = True
  Reply = MsgBox("Table of Contents created." & CRLF & CRLF & _
     "Would you like the tabs in workbook also sorted", _
     vbOKCancel, "Option to Sort " & ActiveWorkbook.Sheets.Count _
     & " tabs in workbook")
  Application.ScreenUpdating = False
  If Reply = 1 Then SortALLSheets  'Invoke macro to Sort Sheet Tabs
  Sheets(sSheetName).Activate
AbortCode:
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
End Sub

Sub BuildTOC_A3()
   Cells(3, 1).Select
   BuildTOC
End Sub

Sub SortALLSheets()
  'sort sheets within a workbook in Excel 7 -- Bill Manville
  'modified to sort all sheets instead of just worksheets
    Dim iSheet As Long, iBefore As Long
  For iSheet = 1 To ActiveWorkbook.Sheets.Count
    Sheets(iSheet).Visible = True
    For iBefore = 1 To iSheet - 1
      If UCase(Sheets(iBefore).Name) > UCase(Sheets(iSheet).Name) Then
        ActiveWorkbook.Sheets(iSheet).Move Before:=ActiveWorkbook.Sheets(iBefore)
        Exit For
      End If
    Next iBefore
  Next iSheet
End Sub

Sub EnumerateAddIns()
    Worksheets("AddinsSheet").Rows(1).font.Bold = True
    Worksheets("AddinsSheet").Range("a1:d1").Value = _
        Array("Name", "Full Name" & "         " & Now(), "Title EnumerateAddIns()", "Installed")
    For i = 1 To AddIns.Count
        Worksheets("AddinsSheet").Cells(i + 1, 1) = AddIns(i).Name
        Worksheets("AddinsSheet").Cells(i + 1, 2) = AddIns(i).FullName
        Worksheets("AddinsSheet").Cells(i + 1, 3) = AddIns(i).title
        Worksheets("AddinsSheet").Cells(i + 1, 4) = AddIns(i).Installed
        Worksheets("AddinsSheet").Cells(i + 1, 5).Value = i
    Next
    Worksheets("AddinsSheet").Range("a1").CurrentRegion.Columns.AutoFit
End Sub

Sub EnumerateSheets_XL95()
  'listed from active cell down 2-cols --  DMcRitchie 1999-03-04
  Application.Calculation = xlManual   'xl97 up use xlCalculationManual  
  Application.ScreenUpdating = False
  cRow = ActiveCell.Row
  cCol = ActiveCell.Column
  For csht = 1 To ActiveWorkbook.Sheets.Count  'worksheet or sheets
     Cells(cRow - 1 + csht, cCol) = "'" & Sheets(csht).Name
     Cells(cRow - 1 + csht, cCol + 1) = TypeName(Sheets(csht))
    '-- include next line if you want to see cell A1 for each sheet
     Cells(cRow - 1 + csht, cCol + 2) = Sheets(Sheets(csht).Name).Range("A1").Value
  Next csht
  Application.ScreenUpdating = True
  Application.Calculation = xlAutomatic   'xl97 up use xlCalculationAutomatic
End Sub

Sub SortSheets()
  'sort worksheets within a workbook in Excel 7 -- Bill Manville
    Dim iSheet As Long, iBefore As Long
    MsgBox ActiveWorkbook.Worksheets.Count & "Sort Worksheets -- Bill Manville"
  For iSheet = 1 To ActiveWorkbook.Worksheets.Count
    Worksheets(iSheet).Visible = True
    For iBefore = 1 To iSheet - 1
      If UCase(Worksheets(iBefore).Name) > UCase(Worksheets(iSheet).Name) Then
        ActiveWorkbook.Worksheets(iSheet).Move Before:=ActiveWorkbook.Worksheets(iBefore)
        Exit For
      End If
    Next iBefore
  Next iSheet
End Sub

Sub SheetNamesAcrossColumns()
'David McRitchie 1999-12-29 http://www.geocities.com/davemcritchie/excel/buildtoc.htm
  Dim iSheet As Long
  For iSheet = 1 To ActiveWorkbook.Worksheets.Count
    ActiveCell.offset(0, iSheet - 1) = Worksheets(iSheet).Name
  Next iSheet
End Sub

Sub ShowSheets()
'Unhide sheets -- Tom Ogilvy 17Jun1999
'Should show all sheets as long as the workbook level protection
' is notturned on.
For Each sh In Sheets
   sh.Visible = True
Next
End Sub

Sub Build_SS_Button()
    'Build button on spreadshee to invoke macro
    'adapted from a posting by "Jim/Nospam" on 30Aug1999
    ActiveCell.Select
    Selection.Copy
    ActiveSheet.Pictures.Add(251, 88, 75, 13).Select
    Selection.Interior.ColorIndex = 8
    Application.CutCopyMode = False
    Selection.OnAction = ActiveCell.Value   'Macro to be invoked
End Sub

Sub getShapeProc()
    'List of buttons/shapes ON THE worksheets
    'based on Shawn Foley, programming group, 1999-09-10
    Dim wks As Worksheet
    Dim shp As Shape
    Cells(1, 1) = "Worksheet"
    Cells(1, 2) = "Shape"
    Cells(1, 3) = "Type"
    Cells(1, 4) = "OnAction"
    nRow = 1
    For Each wks In ActiveWorkbook.Worksheets
        For Each shp In wks.Shapes
            nRow = nRow + 1
            Cells(nRow, 1) = "'" & wks.Name    'i.e. Worksheet  1999-01-10
            Cells(nRow, 2) = shp.Name
            Cells(nRow, 3) = shp.Type
            Cells(nRow, 4) = shp.OnAction
            'Debug.Print wks.Name & Chr(9) & shp.Name & Chr(9) & shp.OnAction
            '------no/no shp.Delete
        Next shp
        'If wks.Name = "Abuse" Then GoTo done  'testing D.McRitchie
    Next wks
done: nRow = nRow + 0
End Sub

Sub delShapesOnSht()
    Dim shp As Shape
    For Each shp In ActiveWorkbook.ActiveSheet.Shapes
            shp.Delete   '****** warning DELETE all Shapes found
    Next shp
End Sub

Sub selShapesOnSht()
    Dim shp As Shape
    For Each shp In ActiveWorkbook.ActiveSheet.Shapes
      ans = MsgBox("DELETE Shape" & Chr(10) & shp.Name & " " _
        & shp.TopLeftCell.Address & Chr(10) & " -- " _
        & shp.AlternativeText, vbYesNoCancel + vbDefaultButton2)
      If ans = 2 Then
        shp.Select                 'Select shape and exit
        Exit Sub
      End If
      If ans = 6 Then shp.Delete   'Delete the shape
    Next shp
End Sub

Sub CheckShape()
'Find names of objects on a sheet -- Tom Ogilvy 01Nov199
'untested (dmcr) has a range("myzone")
Dim varArr()
Dim shpRange As ShapeRange
ReDim varArr(1 To 1)
i = 0
For Each shp In Worksheets("sheet1").Shapes
 If shp.Type = msoFreeform Then
  If Not Intersect(Range("MyZone"), _
    shp.TopLeftCell) Is Nothing Then
      i = i + 1
      ReDim Preserve varArr(1 To i)
      varArr(i) = shp.Name
  End If
 End If
Next
 Set shpRange = ActiveSheet.Shapes.Range(varArr)
 Debug.Print shpRange.Count
 For Each shp In shpRange
   Debug.Print shp.Name, shp.TopLeftCell.Address
 Next
 shpRange.Select
End Sub

Function URL(cell As Range)
  'Tom Ogilvy, programming 1999-04-14 Deja: AN=468281862
  'Chip Pearson, programming 1999-04-14 Deja: AN=468345917
  'David McRitchie, combined 1999-11-13
  Application.ScreenUpdating = False
  If Trim(cell.Formula) = "" Then
     URL = ""
     Exit Function
  End If
  If Left(UCase(cell.Formula), 11) = "=HYPERLINK(" Then
    URL = Mid(cell.Formula, 13, InStr(1, cell.Formula, ",") - 14)
    Exit Function
  End If
  URL = cell.Hyperlinks(1).Address
  Application.ScreenUpdating = True
End Function

Sub MakeTextOnlyFromHyperlinks()
  'David McRitchie, 2000-08-23 worksheet.functions !!
  Dim cell As Range
  Dim URL As String
  For Each cell In Selection
   
    If IsEmpty(cell) Then GoTo chknext
    MsgBox cell.Address
    URL = ""
    On Error Resume Next
    URL = cell.Hyperlinks(1).Address
    'MsgBox cell.Address & " -- " & Err.Number & " -- " & URL
    If Err.Number = 9 Then GoTo chknext
    If Trim(URL) = "" Then GoTo chknext
    cell.Value = URL
    cell.Hyperlinks(1).Delete
chknext:    On Error GoTo 0
  Next cell
End Sub