Option Explicit Private Declare Function timeGetTime Lib "winmm.dll" () As Long '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 'Coding: http://www.mvps.org/dmcritchie/excel/code/gotostuff.txt 'My Excel Macros: http://www.mvps.org/dmcritchie/excel/excel.htm 'Separate coding for ListFunctionsAndSubs can be found at ' http://www.mvps.org/dmcritchie/excel/code/listfsubs.txt '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 delHyperLinksAndText() 'j.Walkenbach version 2000-11-13 'warning clears associated: value, hyperlink, tooltip Dim hl As Variant For Each hl In ActiveSheet.Hyperlinks hl.Parent.Clear Next hl End Sub Sub RemoveScreenTips() 'David McRitchie, misc, 2003-04-08, misc Dim cell As Range For Each cell In Intersect(Selection, ActiveSheet.UsedRange) On Error Resume Next cell.Hyperlinks(1).ScreenTip = "" Next cell End Sub Sub DeleteThisSheet() Dim ans As Variant Dim saveTrue As Variant Dim SheetCodeLines As Long '--requires ref. to the MS VBA Extensibility' library SheetCodeLines = ActiveWorkbook.VBProject.VBComponents _ (ActiveSheet.CodeName).CodeModule.CountOfLines If SheetCodeLines > 2 Then MsgBox ActiveSheet.Name & " -- has " & _ SheetCodeLines & " lines of code (not deleted) " '-- want to open the sheet code here --- ElseIf Left(ActiveSheet.Name, 5) = "Sheet" _ Or Application.WorksheetFunction.CountA(ActiveSheet.Cells) = 0 Then Application.DisplayAlerts = False ActiveSheet.Delete 'tflush_wav Application.DisplayAlerts = True Else Application.DisplayAlerts = True ActiveSheet.Delete End If End Sub Sub Delete_EmptySheets() Dim sh As Worksheet 'Ron de Bruin, programming, 2002-12-28 'On Error Resume Next 'possibility of all sheets blank For Each sh In ThisWorkbook.Worksheets If Application.WorksheetFunction.CountA(sh.Cells) = 0 Then Application.DisplayAlerts = False sh.Delete Application.DisplayAlerts = True End If Next 'On Error goto 0 'Excel must have one sheet/workbook End Sub Sub SelectHyperlinks() 'D.McRitchie 2001-01-24 buildtoc.htm Dim hl As Variant Dim rng1 As String For Each hl In ActiveSheet.Hyperlinks rng1 = rng1 & "," & hl.Parent.Address(0, 0) Next hl If rng1 = "" Then MsgBox "No Hyperlinks found in Sheet, so none in selection" Exit Sub End If rng1 = Right(rng1, Len(rng1) - 1) On Error Resume Next Intersect(Selection, Range(rng1)).Select If Err.Description = "" Then Exit Sub MsgBox "Change your initial selection" & Chr(10) & _ "there are hyperlinks, but none in you initial selection" _ & Chr(10) & Err.number & " " & Err.Description End Sub Sub ConvertHyperlinks() 'David McRitchie, misc, 2000-01-17, misc 'http://www.mvps.org/dmcritchie/excel/buildtoc.htm Dim cell As Range Dim HyperlinkAddress As String, hyperlinkformula As String For Each cell In Selection On Error GoTo skipHyper HyperlinkAddress = cell.Hyperlinks(1).Address On Error GoTo 0 If HyperlinkAddress = "" Then GoTo skipHyper hyperlinkformula = cell.Formula If Left(hyperlinkformula, 1) = "=" Then hyperlinkformula = Right(hyperlinkformula, Len(hyperlinkformula) - 1) Else hyperlinkformula = Replace(hyperlinkformula, """", """""") hyperlinkformula = """" & hyperlinkformula & """" End If cell.Formula = "=HYPERLINK(""" & HyperlinkAddress & _ """," & hyperlinkformula & ")" skipHyper: On Error GoTo 0 Next cell On Error GoTo 0 Selection.Hyperlinks.Delete For Each cell In Selection cell.Formula = cell.Formula Next cell End Sub Sub MakeHyperlinks() Dim cell As Range For Each cell In Intersect(Selection, _ Selection.SpecialCells(xlConstants, xlTextValues)) With Worksheets(1) .Hyperlinks.Add Anchor:=cell, _ Address:=cell.Value, _ ScreenTip:=cell.Value, _ TextToDisplay:=cell.Value End With Next cell End Sub Sub MakeHyperlinkTo_archiveorg() Dim cell As Range, nCell As String For Each cell In Intersect(Selection, _ Selection.SpecialCells(xlConstants, xlTextValues)) ' If LCase(Left(Cell.Value, 7)) <> "http://" Then Exit Sub nCell = "http://web.archive.org/web/*/" On Error Resume Next cell.Offset(0, 2) = "aa" cell.Offset(0, 2).Formula = "=HYPERLINK(""" & nCell _ & """& " & cell.Address(0, 0) & ",""[A]"")" Next cell End Sub Sub MakeHyperlinkFormulas() Dim cell As Range Dim HyperlinkAddress As String, HyperLinkText As String For Each cell In Intersect(Selection, ActiveSheet.UsedRange) HyperlinkAddress = Trim(cell.Text) HyperLinkText = Trim(cell.Text) If HyperLinkText = "" Then GoTo skipit If HyperLinkText <> "" Then If InStr(1, HyperlinkAddress, "@") Then If LCase(Left(HyperlinkAddress, 7)) <> "mailto:" Then HyperlinkAddress = "mailto:" & HyperlinkAddress End If Else If InStr(1, HyperlinkAddress, ".") = 0 Then GoTo skipit If LCase(Left(HyperlinkAddress, 7)) <> "http://" Then HyperlinkAddress = "http://" & HyperlinkAddress End If End If End If cell.Formula = "=HYPERLINK(""" & HyperlinkAddress & _ """,""" & HyperLinkText & """)" skipit: HyperLinkText = "" 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 ' 2000-12-24 to use =HYPERLINK 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 qSht As String Dim mg As String Dim rg As Range Dim CRLF As String Dim Reply As Variant Dim SheetCodeLines As Long 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 + 8)) 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 Cells(cRow - 1 + csht, cCol) = "'" & Sheets(csht).Name If TypeName(Sheets(csht)) = "Worksheet" Then 'hypName = "'" & Sheets(csht).Name qSht = Replace(Sheets(csht).Name, """", """""") If CDbl(Application.VERSION) < 8# 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 '--- excel is not handling lots of objects well --- 'ActiveSheet.Hyperlinks.Add Anchor:=Cells(cRow - 1 + cSht, cCol), _ ' Address:="", SubAddress:="'" & Sheets(cSht).Name & "'!A1" '--- so will use the HYPERLINK formula instead --- '--- =HYPERLINK("[VLOOKUP.XLS]'$$TOC'!A1","$$TOC") '--- double quotes are legal in sheetnames ActiveSheet.Cells(cRow - 1 + csht, cCol).Formula = _ "=hyperlink(""[" & ActiveWorkbook.Name _ & "]'" & qSht & "'!A1"",""" & qSht & """)" End If Else Cells(cRow - 1 + csht, cCol + 2) = "'" & Sheets(csht).Name End If Cells(cRow - 1 + csht, cCol + 1) = TypeName(Sheets(csht)) ' -- activate next line to 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 ' sheets(cSht).type If TypeName(Sheets(csht)) = "Module" Then GoTo byp7 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 '--requires ref. to the MS VBA Extensibility' library SheetCodeLines = ActiveWorkbook.VBProject.VBComponents _ (Sheets(csht).CodeName).CodeModule.CountOfLines If SheetCodeLines > 2 Then Cells(cRow - 1 + csht, cCol + 8) = SheetCodeLines byp7: 'xxx On Error GoTo 0 Next csht ' GoTo AbortCode '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" Cells(cRow - 1, cCol + 8) = "Code" 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 'called by BuildTOC macro you can use another macro... 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 Reverse_SortALLSheets() 'sort sheets within a workbook in Excel 7 -- Bill Manville 'modified to sort all sheets instead of just worksheets 'called by BuildTOC macro you can use another macro... Dim iSheet As Long, iAfter As Long For iSheet = 1 To ActiveWorkbook.Sheets.Count Sheets(iSheet).Visible = True For iAfter = 1 To iSheet - 1 If UCase(Sheets(iAfter).Name) < UCase(Sheets(iSheet).Name) Then ActiveWorkbook.Sheets(iSheet).Move Before:=ActiveWorkbook.Sheets(iAfter) Exit For End If Next iAfter Next iSheet End Sub Sub EnumerateAddIns() Dim i As Long 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 ... Dim shtcount As Name, iWrk As Long, iChrt As Long Dim iMod As Long, iDlg As Long 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. Dim sh As Variant 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 Private Function HyperlinkAddress(cell) As String If cell.Hyperlinks.Count > 0 Then _ HyperlinkAddress = cell.Hyperlinks(1).Address End Function Private Function indented(cell) As Long 'Leading/Left Spaces count, D.McRitchie 2007-07-26 LSpaces = cell.IndentLevel 'cell padding on left End Function Private Function LSpaces(cell) As Long 'Leading/Left Spaces count, D.McRitchie 2007-07-26 LSpaces = Len(Text) - Len(LTrim(Replace(Text, Chr(160), " ", , , vbTextCompare))) End Function Private Function ExtractFilename(cell) As String 'D.McR 2006-07-31 extract filename w/o ext from full pathname Dim str As String, newstring As String str = cell If InStr(str, "\") = 0 Then ExtractFilename = str Exit Function End If newstring = Mid(str, InStrRev(str, "\", , vbTextCompare) + 1) If InStr(newstring, ".") = 0 Then ExtractFilename = newstring Exit Function End If str = Left(str, InStr(newstring, ".") - 1) ExtractFilename = str End Function Private Function HyperlinkFilename(cell) As String 'D.McR 2006-07-31 extract filename w/o ext from an object link Dim str As String, newstring As String str = cell.Hyperlinks(1).Address If cell.Hyperlinks.Count < 1 Then Exit Function If InStr(str, "\") = 0 Then HyperlinkFilename = str Exit Function End If newstring = Mid(str, InStrRev(str, "\", , vbTextCompare) + 1) If InStr(newstring, ".") = 0 Then HyperlinkFilename = newstring Exit Function End If str = Left(str, InStr(newstring, ".") - 1) HyperlinkFilename = str End Function Function HyperLinkText(oRange As Range) As String '-- Bill Manville, 2002-97-26, excel.links '-- includes Excel internal links Dim ST1 As String, ST2 As String If oRange.Hyperlinks.Count = 0 Then Exit Function ST1 = oRange.Hyperlinks(1).Address ST2 = oRange.Hyperlinks(1).SubAddress If ST2 <> "" Then ST1 = "[" & ST1 & "]" & ST2 HyperLinkText = ST1 End Function Function HyperlinkScreenTip(cell) On Error Resume Next HyperlinkScreenTip = cell.Hyperlinks(1).ScreenTip If HyperlinkScreenTip = 0 Then HyperlinkScreenTip = "" End Function 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 ... 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 = "'**" End Function Function URLHREF(cell As Range) 'As an aid to sorting a list of hyperlinked articles 2004-06-22 xlindex.htm '="