Option Explicit
     'Not all have been tested for use with Option Explicit
'Documented in  http://www.mvps.org/dmcritchie/excel/buildtoc.htm
'Coding:  http://www.mvps.org/dmcritchie/excel/code/buildtoc.txt
'My Excel Macros: http://www.mvps.org/dmcritchie/excel/excel.htm

'EnumerateSheets - list of sheets from active cell down, uses two columns
'For reordering sheets, I prefer Jeff Web's "ReOrderSheets"

'ReOrderSheets - reorders sheets within Type
' Types: Worksheet, Chart, Module, Dialogsheet
'SortSheets - reorders only Worksheets
'SortALLSheets - reorders ALL sheets, regardless of type
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 MakeEmailLink()
  Dim cell As Range
  Dim i As Long
  For Each cell In Selection
    If InStr(1, cell, "@") > 0 Then
        With Worksheets(1)
          .Hyperlinks.Add Anchor:=cell, _
           Address:="mailto:" & cell.Value, _
           ScreenTip:=cell.Value, _
           TextToDisplay:=cell.Value
        End With
    End If
  Next cell
End Sub



Sub BuildTOC()
  'listed from active cell down 7-cols --  DMcRitchie 1999-08-14 2000-09-05
  Dim iSheet As Long, iBefore As Long
  Dim sSheetName As String, sActiveCell As String
  Dim cRow As Long, cCol As Long, cSht As Long
  Dim lastcell
  Dim mg As String
  Dim rg As Range
  Dim CRLF As String
  Dim Reply As Variant
  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 + 7))
  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" & Chr(10) & "revised will now occupy up to 10 columns")
     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))
    ' -- activate next line so include content of cell A1 for each sheet
    ' Cells(cRow - 1 + csht, cCol + 3) = Sheets(Sheets(csht).Name).Range("A1").Value
     On Error Resume Next
     Cells(cRow - 1 + cSht, cCol + 6) = Sheets(cSht).ScrollArea '.Address(0, 0)
     Cells(cRow - 1 + cSht, cCol + 7) = Sheets(cSht).PageSetup.PrintArea
     If TypeName(Sheets(cSht)) <> "Worksheet" Then GoTo byp7
     Set lastcell = Sheets(cSht).Cells.SpecialCells(xlLastCell)
     Cells(cRow - 1 + cSht, cCol + 4) = lastcell.Address(0, 0)
     Cells(cRow - 1 + cSht, cCol + 5) = lastcell.Column * lastcell.Row
byp7: 'xxx
     On Error GoTo 0
  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"
        Cells(cRow - 1, cCol + 3) = "[opt.]"
        Cells(cRow - 1, cCol + 4) = "Lastcell"
        Cells(cRow - 1, cCol + 5) = "cells"
        Cells(cRow - 1, cCol + 6) = "ScrollArea"
        Cells(cRow - 1, cCol + 7) = "PrintArea"
     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
  'NOT NEEDED AS BuildTOC works for XL95, XL97, XL2000
  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 ReOrderSheets()
  ' page 48 in  "Using Excel VBA" Jeff Webb
  'for each sheet in a workbook ...
  MsgBox "ReorderSheets -- sorting worksheets -- jeff webb"
  For Each shtcount In Sheets
     'group the different types of sheets together
     Select Case TypeName(shtcount)
        Case "Worksheet"
           iWrk = iWrk + 1
           shtcount.Move After:=Sheets(iWrk)
        Case "Chart"
           iChrt = iChrt + 1
           shtcount.Move After:=Sheets(Worksheets.Count + iChrt)
        Case "Module"
           imod = imod + 1
           shtcount.Move After:=Sheets(Worksheets.Count + Charts.Count + imod)
        Case "DialogSheet"
           iDlg = iDlg + 1
           shtcount.Move After:=Sheets(Worksheets.Count + Charts.Count + Modules.Count + iDlg)
     End Select
  Next shtcount
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
Sub GoToSheet()
  'David McRitchie
  On Error Resume Next
  If Worksheets(ActiveCell.Value) Is Nothing Then
    MsgBox ActiveCell.Value & " -- sheet does not exist"
  Else
    Sheets(ActiveCell.Value).Select
  End If
  On Error GoTo 0
End Sub
Sub GoToNextSheet()
'David McRitchie, 2000-09-07 not posted
'Toolbar button [+]
    On Error Resume Next
    ActiveSheet.Next.Select
    If Err.Number = 91 Then
       MsgBox Err.Number & " You are already in the last worksheet"
    End If
End Sub
Sub GoToPrevSheet()
'David McRitchie, 2000-09-07 not posted
'Toolbar button [-]
    On Error Resume Next
    ActiveSheet.Previous.Select
    If Err.Number = 91 Then
       MsgBox "This is the first worksheet, there are " & _
        "no worksheet tabs to left"
    End If
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
  'cannot process imbedded link to internal sheet yet ...
  Application.ScreenUpdating = False
  If Trim(cell.Formula) = "" Then
     URL = ""
     Exit Function
  End If                            ' 1234567890122
  If Left(UCase(cell.Formula), 11) = "=HYPERLINK(" Then
    If Left(UCase(cell.Formula), 12) = "=HYPERLINK(""" Then
      URL = Mid(cell.Formula, 13, InStr(1, cell.Formula, ",") - 13)
      Exit Function  'next part for nonquoted first parm
    End If
    URL = Mid(cell.Formula, 12, InStr(1, cell.Formula, ",") - 12)
    Exit Function
  End If
  URL = ""
  On Error Resume Next
  URL = cell.Hyperlinks(1).Address
  If URL = 0 Then URL = "'**"
  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
Sub OneSheet_TOC()
'basis Chip Pearson,  misc 2000-10-08 CreateIndex
' -- mod. to summarize fromName-ToName, page
'Scans through column A on Sheet1,
'and creates a page index of each "group" of values onto Sheet2.
'Earlier code basis may be Laurent Longre 2000-03-05 programming
'  which placed   page ?? of ??? right on the spreadsheet.
'  http://www.deja.com/=dnc/getdoc.xp?AN=593502826
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
Dim Rng As Range
Dim Dest As Range
Dim HPB As HPageBreak
Dim pagenumber As Long
Dim PageRows() As Long
Dim xx As String:  xx = ""
ReDim PageRows(0 To Worksheets("Sheet1").HPageBreaks.Count, 0 To 1)
pagenumber = 1
Set Rng = Worksheets("Sheet1").Range("A1")
Set Dest = Worksheets("Sheet2").Range("A1")
'   From,   To,   Page,   Row
    Dest(1, 1) = Rng(1, 1)
    Dest(1, 2) = Rng(1, 1)
    Dest(1, 3) = pagenumber
    Dest(1, 4) = Rng.Row
For Each HPB In Worksheets("Sheet1").HPageBreaks
    xx = xx & ", " & HPB.Location.Row
    Dest(pagenumber, 2) = Rng(HPB.Location.Row - 1, 1)
    pagenumber = pagenumber + 1
    Dest(pagenumber, 1).Value = Rng(HPB.Location.Row, 1)
    Dest(pagenumber, 2).Value = Rng(HPB.Location.Row, 1)
    Dest(pagenumber, 3).Value = pagenumber
    Dest(pagenumber, 4).Value = HPB.Location.Row
Next HPB
  Worksheets("sheet1").UsedRange
  Dest(pagenumber, 2).Value = _
    Rng.Cells(Rng.Cells.SpecialCells(xlLastCell).Row, 1).Value
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
  MsgBox Mid(xx, 2, 9999) & ", " & Chr(187) & _
    Rng.Cells.SpecialCells(xlLastCell).Row & _
    Chr(10) & Chr(187) & " Based on LastCell"
End Sub
' ===============================================================
Sub GoToSub()
   'Display Subroutine or Function named in selected cell
   'David McRitchie 1999-11-12 rev. 2000-04-13
   'http://www.mvps.org/dmcritchie/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 A1TopLeft()
    'Application.Goto Reference:=Range(ActiveCell.Address), Scroll:=True
    Application.Goto Reference:=Range("A1"), Scroll:=True
End Sub
Sub RunSubFromActiveCell()
   Application.Run ActiveCell.Value
End Sub