'Option Explicit
     'Not all have been tested for use with Option Explicit
'Documented in  http://www.mvps.org/dmcritchie/excel/buildtoc.htm
'Documented in  http://www.mvps.org/dmcritchie/excel/toolbars.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
' David McRitchie
'------------------------------------------------
'- 2 subroutines use these by Brian Wilson, Excel Misc, 2000-08-03
Public ThisCell As String
Public ThisSheet As String
Sub GoToCellInFormula()
'Brian Wilson, Excel Misc, 2000-08-03
' go to the first cell referenced in the activecell FORMULA
'
    ThisSheet = ActiveSheet.Name
    ThisCell = ActiveCell.Address
    Selection.ShowPrecedents
    ActiveCell.NavigateArrow TowardPrecedent:=True, _
    ArrowNumber:=1, LinkNumber:=1
    Worksheets(ThisSheet).ClearArrows
End Sub

Sub TakeMeBack()
'Brian Wilson, Excel Misc, 2000-08-03
' return to the original cell
'
    Worksheets(ThisSheet).Activate
    Range(ThisCell).Activate
End Sub

Sub GoToCell_old()
  'David McRitchie   2000-08-03, cont'd based on Brian Wilson
  Dim i As Long
  ThisSheet = ActiveSheet.Name
  ThisCell = ActiveCell.Address
  Dim vCell As String
  vCell = ActiveCell.Value
  i = InStr(1, vCell, "!", 0)
  If i <> 0 Then
     Sheets(Left(vCell, i - 1)).Activate
     Range(Trim(Mid(vCell, i + 1, 99))).Activate
  Exit Sub
  Else
     On Error GoTo TrySheet
     Range(vCell).Select
     Exit Sub
  End If
TrySheet:
  On Error GoTo NF
  Sheets(ActiveCell.Value).Select
  Exit Sub
NF:
  MsgBox "Invalid cell, sheetname, or sheetname!cell"
End Sub
'---------------------------------

Sub GoToCell()
  'David McRitchie   2000-08-03, simplified 2001-03-04 by Dana DeLouis
  On Error GoTo NF
  Application.Goto Range(ActiveCell.Value)
  Exit Sub
NF:
  MsgBox "GoToCell failed at " & ActiveCell.Address & Chr(10) & _
    "   with invalid sheetname and/or cell address, attempting " & _
    Chr(10) & "   to process:  " & ActiveCell.Value
End Sub

Sub GotoTopOfCurrentColumn()
    'Graham Tooley" <GrahamTooley@Xtra.co.nz>  23Apr1998
    'ActiveCell.EntireColumn.Cells(1, 1).Select
    Cells(1, ActiveCell.Column).Select  'J.Campion 2000-03-20
    'would like to hit ctrl or shift + and use this, Tom Ogilvy 2000-06-26
    'Cells(Rows.Count, ActiveCell.Column).End(xlUp).Select
End Sub
Sub GotoBottomOfCurrentColumn()
   'Tom Ogilvy 2000-06-26
   Cells(Rows.Count, ActiveCell.Column).End(xlUp).Select
End Sub

Sub GotoBottomOfColumnA_PlusOne()
   'Tom Ogilvy 2000-06-26
   Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Select
   'Tom Ogilvy 2001-04-11
  ' Dim rng As Range
  ' Set rng = Cells(Rows.Count, "A").End(xlUp)(2)
  ' rng.Select
End Sub
Sub SelectToBottom()
  Range(ActiveCell.Address, _
     Cells(Rows.Count, ActiveCell.Column).End(xlUp).Address).Select
  '-- copy selection to to clipboard
  Selection.Copy
End Sub
Sub GotoRightOfCurrentRow()  'D.McRitchie 2003-12-08 based on Tom Ogilvy
   Cells(ActiveCell.Row, Columns.Count).End(xlToLeft).Offset(0, 1).Select
End Sub
Sub GotoRightmostOfCurrentRow()
   If Not (IsEmpty(Cells(ActiveCell.Row, Columns.Count))) Then
      Cells(ActiveCell.Row, Columns.Count).Select
      Exit Sub
   End If
   Cells(ActiveCell.Row, Columns.Count).End(xlToLeft).Select
   'wsFunct: {=ADDRESS(1,MAX(IF(1:1<>"",COLUMN(1:256),"")),4)}  t.ogilvy 2000-09-25
End Sub

'wsFunct to get value of rightmost cell on a row  -- Don Guillet 2003-12-09, misc
'One way. Must be array entered (Ctrl+Shift+Enter). copy down
'=OFFSET(A3,0,-1+MAX(ISNUMBER(3:3)*COLUMN(1:256)))

Sub gotolastnotlen0()
   Dim lstrow As Long, i As Long  'D.McRitchie 2000-12-04 prog.
   lstrow = Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row
   For i = lstrow To 1 Step -1
     If Len(Cells(i, ActiveCell.Column)) <> 0 Then GoTo done
   Next i
done:
   Cells(i, ActiveCell.Column).Select
End Sub

Sub GotoHomeOfCurrentRow()
    Cells(ActiveCell.Row, 1).Select
    'Same as Home key -- as long a no Transition keys
End Sub

Sub MoveDown()  'D.McRitchie 2000-10-16 like ArrowDn
   ActiveCell.Offset(1, 0).Activate
End Sub
Sub MoveUp()    'D.McRitchie 2000-10-16 like ArrowUp
   ActiveCell.Offset(-1, 0).Activate
End Sub
'---------------------------------
Sub GoTo_XLFDIC()
  'David McRitchie  2001-01-14   Bring up Peter Noneley's Excel Function Dictionary
  'David McRitchie  xxxx www.mvps.org/dmcritchie/excel/buildtoc.htm
  Dim wantedsheet As String
  If ActiveCell.Value = "" Then Exit Sub
  'wantedsheet = "'[C:\Documents and Settings\Administrator\Desktop\XLFDIC01.XLS]" _
   ' & Trim(ActiveCell.Value) & "'!A1"
    
   Workbooks.Open(filename:= _
        "C:\Documents and Settings\Administrator\Desktop\XLFDIC01.XLS").RunAutoMacros _
        Which:=xlAutoOpen
  'Range("[C:\Documents and Settings\Administrator\Desktop\XLFDIC01.XLS]'"
     '   & Trim(ActiveCell.Value) & "'a1").Select
   'Application.Goto Reference:="'" & Trim(ActiveCell.Value) & "'!a1"

  On Error Resume Next
  If Sheets(ActiveCell.Text) Is Nothing Then
     MsgBox "Worksheet " & wantedsheet & " was not found, use RClick on " _
       & "Sheet Tab Navigation arrow in lower left corner " _
       & "to find desired sheetname."
  Else
     Sheets(ActiveCell.Text).Select
  End If
  On Error GoTo 0
End Sub

Sub GoToCellF()
  'David McRitchie  testing 2002-10-11
  'usage   A3:  =Data!B14
  ' macro will take you to Cell at 'data'!B14
  'simulates double click of such a formula when options
  '  tools, options, edit (tab), [uncheck] Edit directly in cell
  On Error GoTo NF
  Application.Goto Reference:=Application.Range(Mid(ActiveCell.Formula, 2))
  Exit Sub
NF:
  MsgBox "GoToCell failed at " & ActiveCell.Address & Chr(10) & _
    "   with invalid sheetname and/or cell address, attempting " & _
    Chr(10) & "   to process single cell reference in formula:  " _
    & ActiveCell.Formula
End Sub
Sub GoToSheet()
  'David McRitchie  www.mvps.org/dmcritchie/excel/buildtoc.htm
  Dim wantedsheet As String
  wantedsheet = Trim(ActiveCell.Text)
  If wantedsheet = "" Then Exit Sub
  On Error Resume Next
  If Sheets(ActiveCell.Text) Is Nothing Then
     MsgBox "Worksheet " & wantedsheet & " was not found, use RClick on " _
       & "Sheet Tab Navigation arrow in lower left corner " _
       & "to find desired sheetname."
  Else
     Sheets(ActiveCell.Text).Select
  End If
  On Error GoTo 0
End Sub

Sub GoToTOC()
  On Error Resume Next
  Sheets("$$TOC").Select
  If Err.number <> 0 Then MsgBox "$$TOC  Sheet Not Found"
End Sub
Sub GoToSheetofNextCell()
  On Error Resume Next
  Sheets(ActiveCell.Offset(0, 1).Value).Select
  If Err.number <> 0 Then MsgBox ActiveCell.Offset(0, 1).Value & _
    " sheet not found relating to " & ActiveCell.Value
End Sub
Sub GoToEnteredSheetName()
  On Error Resume Next
   Err.number = 0
   Dim EmpNo As String
   EmpNo = InputBox("Enter Sheet name", "Sheet Name Entry", _
        ActiveCell.Value, , vbOKCancel)
   If EmpNo = "" Then Exit Sub   'empty or hit Cancel
   Sheets(EmpNo).Select
   If Err.number <> 0 Then MsgBox EmpNo & _
    "  sheet not found"
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
    'Dim strng As String
    'strng = ActiveCell.Address(0, 0)
    ActiveSheet.Previous.Select
    If Err.number = 91 Then
       MsgBox "This is the first worksheet, there are " & _
        "no worksheet tabs to left"
    End If
    'ActiveSheet.Range(strng).Select
End Sub
Sub GoToLastSheet()
'David McRitchie, 2002-02-27
    On Error Resume Next
    Sheets(Sheets.Count).Select
End Sub
Sub GoToSpecificSheet()
'David McRitchie, 2000-11-15 misc
    On Error Resume Next
    Dim getsheet As String
retry9:
    getsheet = InputBox("Supply name of sheet to be selected", _
      "Select a Sheet", ActiveSheet.Name)
    If getsheet = "" Then Exit Sub   'cancelled
    Sheets(getsheet).Select
    If Err.number <> 0 Then
      MsgBox "sheet """ & getsheet & """ not found, respecify or cancel"
      Err.number = 0
      GoTo retry9
    End If
End Sub


Sub GoToCustomerSheet()
     'David McRitchie  2000-07-15   excel.programming
     Dim wantedsheet As String
     wantedsheet = Trim(ActiveCell.Value)
     wantedsheet = InputBox("Please Supply Customer Name" _
        & Chr(10) & "This should match a sheetname", _
        "Specify Customer")
     If wantedsheet = "" Then Exit Sub
     On Error Resume Next
     'to goto a cell you still need to slect the sheet first
     Sheets(wantedsheet).Select
     Sheets(wantedsheet).Range("B14").Select  'Optional
     If Err = 9 Then  'actually is subscript out of range
        MsgBox "Your worksheet was not found use RClick on " _
          & "Sheet Tab Navigation arrow in lower left corner " _
          & "to find desired sheetname."
     End If
End Sub


Sub GoToHyperlink()
  'selected cell  contains   Sheet1!Z100
  '  goto indicated sheet and cell, scroll to display cell in top left corner
  Application.Goto Reference:=Range(ActiveCell.Value), Scroll:=True
End Sub

Sub GoToHTML()
    'David McRitchie, 2000-12-13
    'documented in http://www.mvps.org/dmcritchie/excel/buildtoc.htm
    On Error Resume Next
    If Len(Trim(ActiveCell.Value)) = 0 Then Exit Sub
    ActiveWorkbook.FollowHyperlink Address:=ActiveCell.Value, _
      NewWindow:=False, AddHistory:=True
    If Err.number <> 0 Then
      MsgBox Err.number & " " & Err.Description & Chr(10) & _
      "Tried to bring up file in " & ActiveCell.Address(0, 0) & _
      Chr(10) & "Source:  " & Err.Source & Chr(10) & _
      Chr(10) & "Content: " & Chr(10) & ActiveCell.Text
    End If
   'Application.WindowState = xlNormal -- what would this do?
End Sub

  Sub backupBYDATE()
    'Don Guillett, misc, 2000-05-08  modified filename for date......
    'documented in http://www.mvps.org/dmcritchie/excel/backup.htm
    Dim dname As String, strTest As String
    dname = "c:\mybackup\B" & Format(Now(), "yyyy_mmdd")
    strTest = Dir(dname, vbDirectory)
    If (strTest = "") Then MkDir (dname)
    ActiveWorkbook.SaveCopyAs dname & "\BK_" & ActiveWorkbook.Name
    ActiveWorkbook.Save    'also save current file
  End Sub


'Active cell repositioned to Top also showing 5 cells to left
'   remains on same sheet
Sub ShowTopLeft5()
        Dim caddr As String
    caddr = Selection.Address
    Application.Goto Reference:=Cells(ActiveCell.Row, _
        Application.WorksheetFunction _
        .Max(1, ActiveCell.Column - 5)), Scroll:=True
    Range(caddr).Select
End Sub


'repositition active cell to Top Left corner
'   remains on same sheet
Sub ShowTopLeft()
    Application.Goto Reference:=Range(ActiveCell.Address), Scroll:=True
End Sub
Sub Goback1()
   MsgBox Application.PreviousSelections(1).Address
End Sub
Sub GoBack(Optional n As Byte = 1)
'////////////////not working//////////////////
    MsgBox Application.PreviousSelections(1).Address
On Error GoTo noSelections
For i = LBound(Application.PreviousSelections) To _
            UBound(Application.PreviousSelections)
    MsgBox Application.PreviousSelections(i).Address
Next i
Exit Sub
On Error GoTo 0

noSelections:
    MsgBox "xxxx"
'// Bug fixed in Excel 2000.  (multi-Areas)
'posted 2001-02-28 Dana DeLouis   programming
'-- Excel can go back up to the last 4 active sheets.
  MsgBox n & " --- " & Application.PreviousSelections(1).Address

  If n > 4 Then
    MsgBox "Max n for GoBack is 4 !"
    Stop: Exit Sub
  End If

  With Application.PreviousSelections(n)
    Workbooks(.Parent.Parent.Name).Activate
    Worksheets(.Parent.Name).Activate
    Range(.Address).Select
  End With
End Sub

Sub testchad()
  
    Selection.Item(Selection.Count).Activate
   ' Range("A1:F200").Item(Range("A1:F200").Count).Activate
End Sub

'Private Sub Workbook_BeforeClose(cancel As Boolean)
' -- noticeable slow down and forced/save verification
'  Application.Run "personal.xls!Select_A1_AllSheets"
'End Sub

Sub Select_A1_AllSheets()
    Dim wks As String
    Dim sht As Worksheet
    Application.ScreenUpdating = False
    wks = ActiveSheet.Name
    On Error GoTo done
    For Each sht In Worksheets
      Application.Goto Reference:=sht.Range("A1"), Scroll:=True
    Next sht
    Sheets(wks).Select
done:
    Application.ScreenUpdating = True
End Sub

Sub Select_A1_AllSheets_only()
'if scroll to A1 is not important then no loop needed
    Dim wkstr As String
    wkstr = ActiveSheet.Name
    Worksheets.Select
    Range("A1").Select
    Sheets(wkstr).Select
End Sub
Sub GoTo_nextrow_A()     'ctrl+SHIFT+N  ctrl+Enter
    '-- Advance to Column A of next row
    Cells(ActiveCell.Row + 1, 1).Select
End Sub