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 '="
" & A1 & "" Dim txt As String If cell.Font.Bold Then txt = "" & cell.Text & "" Else txt = cell.Text End If If url(cell) = "" Then URLHREF = txt Else URLHREF = "
" & txt & "" End If End Function Sub URLCHANGE() ' must reduce the presented string to the ' leading portion that you want to change ' David McRitchie, 2000-11-13, may not work properly 'also see Fix192url macro in builttoc.htm Application.Calculation = xlCalculationManual Application.ScreenUpdating = False Dim cell As Range, savevalue As String Dim fromstr As String, tostr As String, fromtst As String Dim updated As Long fromstr = "d:\newsite\davemcritchie\excel\" tostr = "http://www.mvps.org/dmcritchie/excel/" fromtst = fromstr updated = 0 Dim urlstr As String, i As Long fromstr = InputBox("supply from url portion", "URLCHANGE", _ Selection.Hyperlinks(1).Address) If fromstr = "" Then Exit Sub If UCase(fromstr) <> UCase(fromtst) Then tostr = fromstr tostr = InputBox("supply to url portion, to replace" _ & " " _ & Chr(10) & fromstr, "URLCHANG part 2", tostr) If tostr = "" Then Exit Sub End If For Each cell In Selection On Error Resume Next savevalue = cell.Value Err.number = 0 urlstr = cell.Hyperlinks(1).Address If Err.number = 0 Then On Error GoTo 0 'rest back to normal default If Left(UCase(urlstr), Len(fromstr)) = UCase(fromstr) Then urlstr = tostr & Mid(urlstr, Len(fromstr) + 1, 9999) cell.Hyperlinks(1).Address = urlstr cell.Hyperlinks(1).TextToDisplay = urlstr cell.Value = savevalue updated = updated + 1 End If End If On Error GoTo 0 'rest back to normal default Next cell MsgBox "processed " & updated & " cells" Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub 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 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 = "" Dim bastard1004 As Boolean 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 GetAllA1Cells() Application.ScreenUpdating = False Application.Calculation = xlManual Dim iSheet As Long For iSheet = 1 To ActiveWorkbook.Worksheets.Count ActiveCell.Offset(iSheet - 1, 0) = Worksheets(iSheet).[A1].Value ActiveCell.Offset(iSheet - 1, 1) = "'" & Worksheets(iSheet).Name Next iSheet Application.Calculation = xlAutomatic Application.ScreenUpdating = True End Sub Sub ResetScrollArea() ActiveSheet.ScrollArea = InputBox("Supply Scroll area " & _ "or blank out to remove", _ "Supply Scroll Area", ActiveSheet.ScrollArea) End Sub Sub GoToSub(Optional thissub As String) '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 Dim i As Long, trysub As String trysub = thissub On Error GoTo notfound2 If thissub <> "" Then Application.DisplayAlerts = False Application.Goto Reference:=trysub On Error GoTo notfound Application.DisplayAlerts = True End If On Error GoTo notfound 'formerly named GoToSubroutine trysub = Trim(ActiveCell.Value) Application.Goto Reference:=trysub Exit Sub notfound: 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: If InStr(1, ActiveCell.Formula, "!") Then GoTo notfound3 On Error GoTo notfound3 Application.Goto Reference:="pesonal.xls!" & Trim(ActiveCell.Value) MsgBox "Adding the prefix that you didn't specify, pesonal.xls!" Exit Sub notfound3: On Error GoTo 0 MsgBox "Procedure or Function " & ActiveCell.Value _ & " is not available, try ALT+F8 to find Sub, or [fx] to find UDF" End Sub Sub time_RunSubFromActiveCell() 'David McRitchie see slowresp.htm & buildtoc.htm for more information Dim myTime(4) As Double myTime(1) = timeGetTime() '... Your code here for timing Call RunSubFromActiveCell '... End of Your code here for timing myTime(2) = timeGetTime() MsgBox Format((myTime(2) - myTime(1)) / 1000, "#.000") _ & " seconds, " End Sub Sub A1TopLeft() 'Application.Goto Reference:=Range(ActiveCell.Address), Scroll:=True Application.Goto Reference:=Range("A1"), Scroll:=True End Sub Sub RunSubFromActiveCell() '-- examples of what you type into a cell for this to work on ' ''macro1' ' ''personal.xls'!upper_case Dim myTime(4) As Double 'updated 2005-04-29 to include timing Dim actcell As String, bigmess As String, i As Long actcell = Trim(ActiveCell.Text) If InStr(ActiveCell.Text, ".xls'!") And _ Left(ActiveCell.Text, 1) <> "'" Then MsgBox "you need two single quotes at beginning of " & ActiveCell.Text End If i = InStr(ActiveCell.Text, ".xls!") If i > 0 Then 'mod. 2006-05-24 now compatible with GoToSub and macro menu '-- must be in form 'book.xls'!macroname to actually run actcell = "'" & Left(actcell, i + 3) & "'" & Mid(actcell, i + 4, 255) End If bigmess = actcell myTime(1) = timeGetTime() On Error Resume Next Err.Clear If Left(actcell, 1) <> "'" Then Application.Run "'" & Trim(actcell) & "'" Else '-- first single quote does not count it means text field '-- i.e. ''pesonal.xls'!Test_SP_create_crap Application.Run actcell End If On Error GoTo 0 If Err.number <> 0 Then actcell = "'" & ActiveWorkbook.Name & "'!" & actcell myTime(1) = timeGetTime() Err.Clear Application.Run actcell If Err.msg <> 0 Then bigmess = Err.number & " for " & actcell _ & Chr(13) & Err.Description Err.Clear End If End If myTime(2) = timeGetTime() On Error GoTo 0 MsgBox Format((myTime(2) - myTime(1)) / 1000, "#.000") _ & " seconds for " & bigmess '- examples of tests upper_case ="'2004-11.XLS'!DUMBO_CASE" '- ''2004-11.xls'!yougotit '- because this macro runs from personal.xls you must supply bookname. End Sub Sub RunSubFromActiveTest() 'place RunSubFromActiveTest in a cell and run RunSubFromActiveCell MsgBox "have successfully tested RunSubFromActiveCell" End Sub Sub LinkFix() ' Dana DeLouis 2001-03-19 misc, using an ' Idea From: Chip Pearson ' http://www.cpearson.com/excel/clipboar.htm '= = = = = = = = = ' VBA Lib.Ref.: Microsoft Forms 2.0 object lib. ' Excel 2000 due to Replace() Function. '= = = = = = = = = Dim MyDataObj As New DataObject MyDataObj.GetFromClipboard Dim nLnk As String slnk = Replace(MyDataObj.GetText, _ vbCr, vbNullString) slnk = Replace(slnk, vbLf, vbNullString) slnk = Replace(slnk, vbLf, vbNullString) slnk = Replace(slnk, ">", vbNullString) slnk = Replace(slnk, " ", vbNullString) slnk = Replace(slnk, Chr(160), vbNullString) MyDataObj.SetText slnk MyDataObj.PutInClipboard Set MyDataObj = Nothing End Sub 'MakeHTML_Link has been moved to it's own code module Function MSKBQ(qstr As String) As String Dim L As Long MSKBQ = qstr If LCase(Left(qstr, 1)) <> "q" Then GoTo done L = Len(qstr) If Not IsNumeric(Right(qstr, L - 1)) Then GoTo done If L < 7 Or L > 10 Then GoTo done ' MSKBQ = "http://support.microsoft.com/support/kb/articles/" & _ Left(qstr, l - 3) & "/" & Mid(qstr, l - 2, 1) _ & "/" & Right(qstr, 2) & ".asp" MSKBQ = "http://support.microsoft.com/?id=kb;en-us;" & UCase(qstr) done: End Function Sub LinkFix_GoTo() ' Dana DeLouis 2001-03-19 misc, ' Dave Peterson, added FollowHyperlink ' Idea From: Chip Pearson ' www.cpearson.com/excel/clipboar.htm '= = = = = = = = = ' VBA Library Reference: ' Microsoft Forms 2.0 object lib. ' Excel 2000 due to Replace() Function. '= = = = = = = = = Dim MyDataObj As New DataObject Dim lnk As String On Error Resume Next MyDataObj.GetFromClipboard lnk = Replace(MyDataObj.GetText, _ vbCrLf, vbNullString) Set MyDataObj = Nothing ActiveWorkbook.FollowHyperlink _ Address:=lnk, NewWindow:=True End Sub 'Sub IdentifyNonFormulaLinks() ' Cells.Hyperlinks.Count ' If Cells.Hyperlink.Count = 0 Then Exit Sub ' cells.hyperlinks.select '<-- not legal 'End Sub 'querylastcells moved to mcritchie_lastcell module Sub CB_List() Worksheets.Add 'Cells(i, 3) = c.enable Dim i As Long i = 1 Cells(i, 1) = "Name" Cells(i, 2) = "Enabled" Cells(i, 3) = "BuiltIn" Cells(i, 4) = "Index" Cells(i, 5) = "Visible" Cells(i, 6) = "Context" Cells(i, 7) = "Controls" Cells(i, 8) = "Creator" Cells(i, 9) = "Parent" Cells(i, 10) = "Application" Dim c As CommandBar For Each c In CommandBars On Error GoTo 0 i = i + 1 Cells(i, 1) = c.Name If c.Enabled = True Then Cells(i, 3) = "True" On Error Resume Next Cells(i, 3) = c.BuiltIn Cells(i, 4) = c.Index Cells(i, 5) = c.Visible Cells(i, 6) = c.Context Cells(i, 7) = c.Controls Cells(i, 8) = c.Creator Cells(i, 9) = c.Parent Cells(i, 10) = c.Application Next c End Sub Sub RevertToLink() Dim cell As Range For Each cell In Selection ' On Error Resume Next cell.Value = cell.Hyperlinks(1).Address 'If cell = 0 Then cell = "" Next cell End Sub Sub volatileS() Dim rng As Range, cell As Range, c As Range ' CELL(), INDIRECT(), INFO(), OFFSET(), NOW(), RAND(), TODAY() ' Set c = Union(Cells.Find("CELL(", , xlFormulas), _ ' Cells.Find("INDIRECT(", , xlFormulas), _ ' Cells.Find("INFO(", , xlFormulas), _ ' Cells.Find("OFFSET(", , xlFormulas), _ ' Cells.Find("NOW(", , xlFormulas), _ ' Cells.Find("RAND(", , xlFormulas), _ ' Cells.Find("TODAY(", , xlFormulas)) ' If Not c Is Nothing Then MsgBox "Volatile" End Sub Sub ReplaceHyperlinkAddress(FromAddress As String, ToAddress As String) ' Bill Manville, Links, 2003-01-01 '-- - Sub FixMyLinks() '-- - Call ReplaceHyperlinkAddress("cbsonline.com", "cbs.com") '-- - End Sub Dim H As Hyperlink Dim WS As Worksheet MsgBox FromAddress & " == " & ToAddress For Each WS In ActiveWorkbook.Worksheets For Each H In WS.Hyperlinks If InStr(1, H.Address, FromAddress, vbTextCompare) > 0 Then H.Address = Replace(H.Address, FromAddress, ToAddress, _ vbTextCompare) End If Next Next End Sub Function getdomain(url As String) As String Dim x As String, i As Long, j As Long x = url i = InStr(x, "://") If i <> 0 Then x = Mid(x, i + 3) i = InStr(x, ".") If i = 0 Then getdomain = x Exit Function End If i = InStr(x, "/") If i <> 0 Then x = Left(x, i - 1) x = strReverse(x) i = InStr(x, ".") j = InStr(Mid(x, i + 1), ".") getdomain = x & " " & i & " " & j If j = 0 Then getdomain = strReverse(x) Else getdomain = strReverse(Left(x, i + j - 1)) End If End Function Function MSGID_asLink(msg) ' David McRitchie 2004-=6-24 as Function Dim slnk As String slnk = msg slnk = Replace(slnk, vbCr, vbNullString) slnk = Replace(slnk, vbLf, vbNullString) slnk = Replace(slnk, ">", vbNullString) slnk = Replace(slnk, "<", vbNullString) slnk = Replace(slnk, " ", vbNullString) slnk = Replace(slnk, Chr(160), vbNullString) slnk = Replace(slnk, "Message-ID:", "news:") slnk = Replace(slnk, "References:", "news:") slnk = Replace(Replace(slnk, "#", "%23"), "$", "%24") MSGID_asLink = slnk End Function Function HTMLify(cell As String) As String ' David McRitchie 2005-06-06 Dim slnk As String slnk = cell slnk = Replace(slnk, "&", "&") slnk = Replace(slnk, "<", "<") slnk = Replace(slnk, ">", ">") slnk = Replace(slnk, "<", "<") HTMLify = slnk End Function Sub Make_oldhyp() Dim cell As Range, i As Long, vvv As Variant, lnk As String Dim L As Long For Each cell In Intersect(Selection, Cells.SpecialCells(xlCellTypeFormulas)) If UCase(Left(cell.Formula, 12)) = "=HYPERLINK(""" Then i = InStr(1, cell.Formula, """,") L = Len(cell.Formula) lnk = Mid(cell.Formula, 13, i - 13) With Worksheets(1) .Hyperlinks.Add Anchor:=cell, Address:=lnk 'cell.Formula = "=" & Mid(cell.Formula, i + 2, L - i - 2) cell.Value = cell.Value End With End If Next cell End Sub