Option Explicit 
 
Sub FloatingBar() 
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     ' Purpose:      Add all sheet and range names in current workbook to
     '               combo boxes on a floating toolbar
     ' Restrictions: * Sheet names need to be sorted alphabetically by calling
     '                 'BubbleSort' procedure
     '               * List of range names needs to exclude print area, print
     '                 titles, and filtered ranges
     '               * Need to capture position of existing toolbar, so that the
     '                 updated toolbar is created in the same spot
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     
    Dim objBar As CommandBar ' toolbar
    Dim objCombo As CommandBarComboBox ' combo box on toolbar
    Dim objButton As CommandBarButton ' button on toolbar
    Dim wks As Worksheet ' sheets in workbook
    Dim nm As Name ' range names in workbook
    Dim strSheet() As String ' name of sheets in workbook
    Dim strRange() As String ' name of ranges of workbook
    Dim lngLeft As Long ' left edge of existing toolbar
    Dim lngTop As Long ' top edge of existing toolbar
    Dim lngPosition As Long ' position of existing toolbar
    Dim i As Integer ' counter
     
     
    On Error GoTo ErrHandler 
    i = 1 
     
     ' check that workbook contains at least some sheets
    On Error Resume Next 
    Debug.Print ActiveWorkbook.Sheets.Count 
     
    If Err.Number <> 0 Then 
        MsgBox "There are no sheets in the current workbook.", vbInformation, "No Sheets Available" 
         
    Else 
        On Error GoTo ErrHandler 
         
         ' capture the name of all sheets
        For Each wks In ActiveWorkbook.Sheets 
            ReDim Preserve strSheet(1 To i) 
            strSheet(i) = wks.Name 
            i = i + 1 
        Next wks 
         
         ' sort the list of sheet names
        BubbleSort strSheet 
         
        On Error Resume Next 
        Debug.Print ActiveWorkbook.Names(1).Name 
         
         ' range names found
        If Err.Number = 0 Then 
            On Error GoTo ErrHandler 
            i = 1 
             ' capture the name of all ranges
            For Each nm In ActiveWorkbook.Names 
                 ' exclude print area, print titles and filter ranges
                If InStr(1, nm.Name, "Print_Area") = 0 And _ 
                InStr(1, nm.Name, "Print_Titles") = 0 And _ 
                InStr(1, nm.Name, "_FilterDatabase") = 0 Then 
                     
                    ReDim Preserve strRange(1 To i) 
                    strRange(i) = nm.Name 
                     
                    i = i + 1 
                End If 
            Next nm 
        End If 
         
        On Error Resume Next 
         
         ' create the toolbar
        Set objBar = CommandBars.Add(Name:="Navigation", Position:=msoBarFloating, _ 
        Temporary:=False) 
         
         ' error occurs if toolbar already exists
        If Err.Number <> 0 Then 
            Set objBar = CommandBars("Navigation") 
             
             ' capture current position so that toolbar doesn't move when
             ' recreated
            lngLeft = objBar.Left 
            lngTop = objBar.Top 
            lngPosition = objBar.Position 
             
             ' delete the existing toolbar and recreate
            objBar.Delete 
             
            Set objBar = CommandBars.Add(Name:="Navigation", Position:=msoBarFloating, _ 
            Temporary:=False) 
             
             ' move the new toolbar to the same position as the old one
            objBar.Left = lngLeft 
            objBar.Top = lngTop 
            objBar.Position = lngPosition 
        End If 
         
        On Error GoTo ErrHandler 
         
        objBar.Visible = True 
         
         ' create combo box containing list of sheets
        Set objCombo = objBar.Controls.Add(Type:=msoControlComboBox) 
         
        With objCombo 
            .AddItem "<Select sheet name>" 
             
             ' add each sheet name to the combo box
            For i = 1 To UBound(strSheet) 
                .AddItem strSheet(i) 
            Next i 
             
            .Width = 250 
            .Style = msoComboNormal 
            .OnAction = "GoToSheet" 
            .Caption = "Select Sheet" 
             
             ' select the first item in the list
            .Text = "<Select sheet name>" 
        End With 
         
        On Error Resume Next 
        Debug.Print ActiveWorkbook.Names(1).Name 
         
         ' if range names were found
        If Err.Number = 0 Then 
             ' create combo box containing list of range names
            Set objCombo = objBar.Controls.Add(Type:=msoControlComboBox) 
             
            With objCombo 
                .AddItem "<Select range name>" 
                 
                 ' add each range name to the combo box
                For i = 1 To UBound(strRange) 
                    .AddItem strRange(i) 
                Next i 
                 
                .Width = 250 
                .Style = msoComboNormal 
                .OnAction = "GoToRange" 
                .Caption = "Select Range" 
                 
                 ' select the first item in the list
                .Text = "<Select range name>" 
            End With 
        End If 
         
         ' create button to refresh the list
        Set objButton = objBar.Controls.Add(Type:=msoControlButton) 
         
        With objButton 
            .Caption = "Refresh List" 
            .Style = msoButtonCaption 
            .OnAction = "FloatingBar" 
        End With 
    End If 
     
     
ExitHere: 
    Exit Sub 
     
ErrHandler: 
    MsgBox Err.Number & ": " & Err.Description 
    Resume ExitHere 
End Sub 
 
Sub GoToSheet() 
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     ' Purpose:      Go to the sheet selected in the combo box
     ' Restrictions: The toolbar does not update automatically when a new
     '               workbook is made active, so need to check that the sheet
     '               exists in the current workbook
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     
    Dim lngSelected As Long ' selected item in combo box
    Dim strSheet As String ' name of sheet selected
     
     
    On Error GoTo ErrHandler 
     
    lngSelected = CommandBars("Navigation").Controls(1).ListIndex 
    strSheet = CommandBars("Navigation").Controls(1).List(lngSelected) 
     
     ' first item in list of sheets does not refer to an actual sheet
    If strSheet <> "<Select sheet name>" Then 
         
         ' check that current workbook contains selected sheet
        On Error Resume Next 
        Debug.Print ActiveWorkbook.Sheets(strSheet).Visible 
         
         ' sheet found in active workbook
        If Err.Number = 0 Then 
             ' prompt the user if sheet is hidden
            If ActiveWorkbook.Sheets(strSheet).Visible = False Then 
                If vbYes = MsgBox("This sheet is is hidden." & vbCrLf & vbCrLf & _ 
                "Do you want to unhide the sheet?", vbQuestion + vbYesNo + _ 
                vbDefaultButton2, "Hidden Sheet") Then 
                     
                    ActiveWorkbook.Sheets(strSheet).Visible = True 
                    ActiveWorkbook.Sheets(strSheet).Select 
                End If 
                 
            Else 
                ActiveWorkbook.Sheets(strSheet).Select 
            End If 
             
        Else 
             ' sheet not found
            MsgBox "That sheet could not be located in the current workbook." & _ 
            vbCrLf & vbCrLf & "Please click on 'Refresh List' to update the " & _ 
            "list of sheet names and ranges.", vbInformation, "Sheet Not Found" 
        End If 
    End If 
     
     
ExitHere: 
    Exit Sub 
     
ErrHandler: 
    MsgBox Err.Number & ": " & Err.Description 
    Resume ExitHere 
End Sub 
 
Sub GoToRange() 
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     ' Purpose:      Go to the range name selected in the combo box
     ' Restrictions: * Cannot go to an external workbook
     '               * If sheet is hidden, prompt the user to unhide the sheet
     '               * The toolbar does not update automatically when a new
     '                 workbook is made active, so need to check that the sheet
     '                 exists in the current workbook
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     
    Dim lngSelected As Long ' selected item in combo box
    Dim strRange As String ' name of range selected
    Dim strSheet As String ' name of sheet on which range is located
     
     
    On Error GoTo ErrHandler 
     
     ' which range name was selected in the combo box?
    lngSelected = CommandBars("Navigation").Controls(2).ListIndex 
    strRange = CommandBars("Navigation").Controls(2).List(lngSelected) 
     
     ' first item in list of ranges does not refer to an actual range name
    If strRange <> "<Select range name>" Then 
         ' check that range exists in the active workbook
        On Error Resume Next 
        Debug.Print ActiveWorkbook.Names(strRange).RefersTo 
         
         ' range name found
        If Err.Number = 0 Then 
            strRange = ActiveWorkbook.Names(strRange).RefersTo 
             
             ' can't select external reference
            If InStr(1, LCase(strRange), ".xls") > 0 Then 
                MsgBox "This range refers to an external workbook.", vbInformation, _ 
                "Cannot Select Range" 
                GoTo ExitHere 
                 
                 ' find sheet on which the range resides
            ElseIf InStr(1, strRange, "!") > 0 Then 
                strSheet = Left(strRange, InStr(1, strRange, "!") - 1) 
                strSheet = Replace(strSheet, "'", "") 
                strSheet = Replace(strSheet, "=", "") 
                 
                strRange = Mid(strRange, InStr(1, strRange, "!") + 1) 
                 
                 ' prompt the user if range is on a hidden sheet
                If ActiveWorkbook.Sheets(strSheet).Visible = False Then 
                    If vbYes = MsgBox("This range is on a hidden sheet." & vbCrLf & vbCrLf & _ 
                    "Do you want to unhide the sheet?", vbQuestion + vbYesNo + _ 
                    vbDefaultButton2, "Range on Hidden Sheet") Then 
                         
                        ActiveWorkbook.Sheets(strSheet).Visible = True 
                        ActiveWorkbook.Sheets(strSheet).Select 
                         
                    Else 
                        GoTo ExitHere 
                    End If 
                     
                Else 
                     ' select the relevant sheet
                    ActiveWorkbook.Sheets(strSheet).Select 
                End If 
            End If 
             
             ' select the range
            Range(strRange).Select 
             
        Else 
             ' range not found
            MsgBox "That range name could not be located in the current workbook." & _ 
            vbCrLf & vbCrLf & "Please click on 'Refresh List' to update the " & _ 
            "list of sheet names and ranges.", vbInformation, "Range Name Not Found" 
        End If 
    End If 
     
     
ExitHere: 
    Exit Sub 
     
ErrHandler: 
    MsgBox Err.Number & ": " & Err.Description 
    Resume ExitHere 
End Sub 
 
Public Sub BubbleSort(ByRef strArray() As String) 
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     ' Purpose:  Sort an array
     '           Algorithm courtesy of "Squirm" at the Visual Basic Forum
     '           http://www.visualbasicforum.com/showthread.php?t=78889
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     
    Dim lngOuter As Long ' counter for outer loop
    Dim lngInner As Long ' counter for innter loop
    Dim lngLBound As Long ' smallest available subscript of array
    Dim lngUBound As Long ' largest available subscript of array
    Dim strTemp As String ' temp for name of string
     
     
    lngLBound = LBound(strArray) 
    lngUBound = UBound(strArray) 
     
     ' Which bubbling pass
    For lngOuter = lngLBound To lngUBound 
         ' Which comparison
        For lngInner = lngLBound To lngUBound - lngOuter 
             
             ' Compare this item to the next item
            If strArray(lngInner) > strArray(lngInner + 1) Then 
                 ' Swap
                strTemp = strArray(lngInner) 
                strArray(lngInner) = strArray(lngInner + 1) 
                strArray(lngInner + 1) = strTemp 
            End If 
        Next lngInner 
    Next lngOuter 
End Sub