Option Explicit

Sub ShowShortcuts()
   'based on Laurent Longre, 2004-02-28 pvt corr.
   'privately 2004-03-10
   Dim Ctrl As CommandBarControl
   Dim i As Long
   Application.Calculation = xlCalculationManual
   Application.ScreenUpdating = False
   On Error Resume Next
      i = 1
       Cells(i, 1) = "Parent"                   'Macro -- menu
         Cells(i, 2) = "Shortcut"           'Alt+F8
         Cells(i, 3) = "Name"               'Macros
         Cells(i, 4) = "Description"        'Macros button
         Cells(i, 5) = "ID"                 '186
         Cells(i, 6) = "Caption"            '&Macros...
         Cells(i, 7) = "Application"          '
         Cells(i, 8) = "DescriptionText"      '
         Cells(i, 9) = "Index"                '
         Cells(i, 10) = "Tag"                 '
         Cells(i, 11) = "TooltipText"         'Run Macro
   i = 2
   For Each Ctrl In CommandBars.FindControls
      If Ctrl <> "" Then
         If Left(Ctrl.Parent.Name, 3) = "My " Or _
             Ctrl.accKeyboardShortcut <> "" Then Cells(i, 12) = "x"
         Cells(i, 1) = Ctrl.Parent.Name          'Macro -- menu
         Cells(i, 2) = Ctrl.accKeyboardShortcut  'Alt+F8
         Cells(i, 3) = Ctrl.accName              'Macros
         Cells(i, 6) = Ctrl.Caption              '&Macros...
         Cells(i, 7) = Ctrl.Application          '
         Cells(i, 8) = Ctrl.DescriptionText      '
         Cells(i, 9) = Ctrl.Index                '
         Cells(i, 10) = Ctrl.Tag                 '
         Cells(i, 11) = Ctrl.TooltipText         'Run Macro
         i = i + 1
      End If
   Next
   Columns("A:L").AutoFit
   Application.ScreenUpdating = True
   Application.Calculation = xlCalculationAutomatic
End Sub

Sub ShowShortcuts_inMenus()
   'based on Laurent Longre, 2004-02-28 pvt corr.
   'David McRitchie, menu.htm, 2005-05-01
   Dim Ctrl As CommandBarControl
   Dim i As Long, j As Long
   Application.Calculation = xlCalculationManual
   Application.ScreenUpdating = False
   On Error Resume Next
      i = 1
       Cells(i, 1) = "Parent"                   'Macro -- menu
         Cells(i, 2) = " Shortcut"          'Alt+F8
         Cells(i, 3) = "Name"               'Macros
         Cells(i, 4) = "TooltipText"        'Run Macro
   i = 2
   For Each Ctrl In CommandBars.FindControls
      If Ctrl <> "" Then
       If Left(Ctrl.Parent.Name, 3) = "My " Or _
             Ctrl.accKeyboardShortcut <> "" Then
         Cells(i, 1) = Ctrl.Parent.Name          'Macro -- menu
         Cells(i, 2) = Ctrl.accKeyboardShortcut  'Alt+F8
         Cells(i, 3) = Ctrl.accName              'Macros
         Cells(i, 4) = Ctrl.TooltipText          'Run Macro
         i = i + 1
       End If
      End If
   Next
   '- some fixups for HTML usage
   Columns("A:G").AutoFit
   Columns("A:A").Replace What:="Custom Popup *", replacement:="Custom Popup", _
        lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
   Columns("C:D").Replace What:=" (", replacement:="<br>&nbsp;(", _
        lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
   Columns("C:D").Replace What:="Can't ", replacement:="", _
        lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
   Columns("D:D").Select
   Run "'personal.xls'!fix_U_menu"
   With Rows("1:1")
      .Font.Bold = True
      .Font.ColorIndex = 5
   End With
   Rows("2:2").FreezePanes = True
   '- sort
   Cells.Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("C2") _
        , Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom
   For i = Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
     For j = 1 To 5
        If Cells(i, j) <> Cells(i - 1, j) Then GoTo not_now
     Next j
     Rows(i).Delete
not_now:
   Next i
   Application.ScreenUpdating = True
   Application.Calculation = xlCalculationAutomatic
End Sub


Sub fix_U_menu()
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Dim cell As Range, i As Long, rng As Range
  'On Error Resume Next   'In case no cells in selection
  Set rng = Selection
  For Each cell In Intersect(rng, _
         rng.SpecialCells(xlConstants, xlTextValues))
     i = InStr(1, cell.Value, "&")
     If i <> 0 Then
       cell.Value = Left(cell.Value, i - 1) & _
         "<u>" & Mid(cell.Value, i + 1, 1) & _
         "</u>" & Mid(cell.Value, i + 2)
     End If
  Next
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  '-- see showshortcuts
End Sub