List of Macro Shortcuts in worksheet

[mrdhorton]

I have inherited a worksheet that has 12 macros I can run from Tools/Macros. Some of these macros have keyboard shortcuts, some don't. I can "walk through" the list to find out which ones do or don't but if I get a worksheet with 50 or so macros that takes a bit of time.

Question: How can I get a list of the keyboard shortcuts that belong to each macro without stepping through the list?

Thanks for any assistance.

 

[BrianB]

The macro code usually contains "Keyboard Shortcut" or "OnKey" which can be searched for.

 

[Tom Urtis]

Question: How can I get a list of the keyboard shortcuts that belong to each macro without stepping through the list?

This code from Ivan Moala does that, thanks Ivan.



Option Explicit


Const strAttrShC As String = "VB_ProcData.VB_Invoke_Func = "
Const strAttrSub As String = "Attribute "
Const strFoobar As String = "ZZZZzzzz"

Dim strShortCuts() As String
Dim j As Integer

Sub mGetShortCutKeys()
'// By Ivan F Moala
'// http://www.XcelFiles.com
'// Testing done Xl97 & 2000
'// Needs a Reference to MS Visual Basics for Applications Extensibilty lib
Dim strTempModFile As String
Dim NoComponents As Long
Dim i As Integer
Dim VBP As Object

Set VBP = ActiveWorkbook.VBProject
NoComponents = VBP.VBComponents.Count

'// Set a Temp path
strTempModFile = ActiveWorkbook.Path & Application.PathSeparator & "Tmp.Txt"
'// inialize count
j = 0

On Error Resume Next
For i = 1 To NoComponents
'// We only want Modules
If VBP.VBComponents(i).Type = 1 Then
With VBP.VBComponents(i)
'// Export The ActiveWorkbooks CodeModule
.Export strTempModFile
ReadAttribute strTempModFile
End With
End If
Next

'// Now display it to a Sheet
With ActiveWorkbook
.Sheets.Add
.ActiveSheet.[A1].Resize(UBound(strShortCuts()) + 1, 1) = _
Application.WorksheetFunction.Transpose(strShortCuts())
.ActiveSheet.Columns("A").Columns.AutoFit
.ActiveSheet.Columns("A").Columns.HorizontalAlignment = xlLeft
End With

Erase strShortCuts()

End Sub

Function ReadAttribute(strBas As String) As String
Dim strTxt As String
Dim handle As Long
Dim Pos As Long
Dim NewPos As Long
Dim PosSub As String
Dim x As Integer
Dim ShortCutKey As String
Dim SubName As String
Dim blnShift As Boolean

'// Open bas file in binary mode
handle = FreeFile
Open strBas For Binary As #handle
'// Parse enougth spaces for text
strTxt = Space(LOF(handle))
'// Read the string IN and Close the file
Get #handle, , strTxt
Close #handle

'// Lets get the ShortCut Key!
Pos = 0: NewPos = 0: x = 0
Do
Pos = InStr(NewPos + 1, strTxt, strAttrShC)
ShortCutKey = Mid(strTxt, Pos + Len(strAttrShC) + 1, 1)
'// Is it a shortCut
If ShortCutKey = " " Then GoTo Skip
If Pos Then
'// Build SC Key
blnShift = (Asc(ShortCutKey) < 97)
ShortCutKey = IIf(blnShift, "Ctrl + shift + " & ShortCutKey, "Ctrl + " & ShortCutKey)
x = Pos
Do Until PosSub = " "
PosSub = Mid(strTxt, x - 1, 1)
x = x - 1
Loop
SubName = Mid(strTxt, x, Pos - x - 1)
ReDim Preserve strShortCuts(j)
strShortCuts(j) = "Sub Routine Name:= " & SubName & _
" [ ShortCut:= " & ShortCutKey & " ]"
j = j + 1
PosSub = strFoobar
End If
Skip:
NewPos = Pos
Loop Until Pos = 0

'// Cleanup - Delete it
Kill strBas

End Function

 

[erik.van.geit]

Hi,

First spending 15 minutes to EDIT this code to enhance the outcome-layout.

'this code is made by Ivan F Moala
'edits by Erik Van Geit ==>
    'only purpose: changing layout of outcome

Option Explicit

Const strAttrShC As String = "VB_ProcData.VB_Invoke_Func = "
Const strAttrSub As String = "Attribute "
Const strFoobar As String = "ZZZZzzzz"

Dim strSubroutines() As String
Dim strShortCuts() As String
Dim j As Integer

Sub mGetShortCutKeys()
'// By Ivan F Moala
'// http://www.XcelFiles.com
'// Testing done Xl97 & 2000
'// Needs a Reference to MS Visual Basic for Applications Extensibility lib
Dim strTempModFile As String
Dim NoComponents As Long
Dim i As Integer
Dim VBP As Object

Set VBP = ActiveWorkbook.VBProject
NoComponents = VBP.VBComponents.Count

'// Set a Temp path
strTempModFile = ActiveWorkbook.Path & Application.PathSeparator & "Tmp.Txt"
'// inialize count
j = 0

On Error Resume Next
    For i = 1 To NoComponents
    '// We only want Modules
        If VBP.VBComponents(i).Type = 1 Then
            With VBP.VBComponents(i)
            '// Export The ActiveWorkbooks CodeModule
            .Export strTempModFile
            ReadAttribute strTempModFile
            End With
        End If
    Next

'// Now display it to a Sheet
    With ActiveWorkbook
    .Sheets.Add
        With .ActiveSheet
        .[A1] = "sub"
        .[B1] = "shortcut"
            With .[A2].Resize(UBound(strShortCuts()) + 1, 1)
            .Value = Application.WorksheetFunction.Transpose(strSubroutines())
            .Offset(0, 1) = Application.WorksheetFunction.Transpose(strShortCuts())
            End With
        End With
        With .ActiveSheet.Columns("A").Columns
        .AutoFit
        .HorizontalAlignment = xlLeft
        End With
    End With

Erase strShortCuts()

End Sub

Function ReadAttribute(strBas As String) As String
Dim strTxt As String
Dim handle As Long
Dim Pos As Long
Dim NewPos As Long
Dim PosSub As String
Dim x As Integer
Dim ShortCutKey As String
Dim SubName As String
Dim blnShift As Boolean

'// Open bas file in binary mode
handle = FreeFile
Open strBas For Binary As #handle
'// Parse enough spaces for text
strTxt = Space(LOF(handle))
'// Read the string IN and Close the file
Get #handle, , strTxt
Close #handle

'// Lets get the ShortCut Key!
Pos = 0: NewPos = 0: x = 0
    Do
    Pos = InStr(NewPos + 1, strTxt, strAttrShC)
    Cells(1, 1) = strTxt
    ShortCutKey = Mid(strTxt, Pos + Len(strAttrShC) + 1, 1)
        '// Is it a shortCut
        If ShortCutKey <> " " Then
            If Pos Then
            '// Build SC Key
            blnShift = (Asc(ShortCutKey) < 97)
            ShortCutKey = IIf(blnShift, "Ctrl + shift + " & ShortCutKey, "Ctrl + " & ShortCutKey)
            x = Pos
                Do Until PosSub = " "
                PosSub = Mid(strTxt, x - 1, 1)
                x = x - 1
                Loop
            SubName = Mid(strTxt, x + 1, Pos - x - 2)
            ReDim Preserve strShortCuts(j)
            ReDim Preserve strSubroutines(j)
            
            strShortCuts(j) = ShortCutKey
            strSubroutines(j) = SubName
            j = j + 1
            PosSub = strFoobar
            End If
        End If
    NewPos = Pos
    Loop Until Pos = 0

'// Cleanup - Delete it
Kill strBas

End Function

but perhaps he could have done this himself ...
let's take a look at his site ...

yes HE DID!!
you will find an Add-In on his site

kind regards,
Erik