略語辞書 for Excel

これは何か

Excelで書かれた資料の中で知らない略語があったときに、そのセルを選択して[F10]キーを押すと、
ウィンドウ下部のステータスバーに意味が2秒間表示されるというマクロ

準備

辞書用ブックのシートに、略語とその意味を記しておく
（本当は辞書になかったらWikipediaを調べて辞書に追加するところまで作ろうと思ってた）

コード

・参照設定
　　Microsoft Scripting Runtime
　　Microsoft VBScript Regular Expression 5.5

'thisworkbook.cls

Option Explicit

Dim MyDictionary As New Dictionary
Dim RYAK_EX As New RegExp
Dim RYAK_PA As New RegExp

Private Sub Workbook_Open()
    Application.OnKey "{F10}", "Thisworkbook.main"
    MakeDictionary
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.OnKey "{F10}"
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    MakeDictionary
End Sub

Sub MakeDictionary()
    On Error Resume Next
    With RYAK_EX
        .Pattern = "^[A-Z][A-Z0-9\-]*[A-Z]$"
    End With
    With RYAK_PA
        .Global = True
        .Pattern = "[A-Z][A-Z0-9\-]*[A-Z]"
    End With
    Dim c As Range, ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        For Each c In ws.Cells.SpecialCells(xlCellTypeConstants)
            If RYAK_EX.Test(c.Value) Then
                MyDictionary(c.Value) = Join(Array(ws.Name, c.Value, ":", c.Offset(, 1).Value))
            End If
        Next c
    Next ws
End Sub

Function LookupDictionary(key As String) As String
    If MyDictionary.Exists(key) Then
        LookupDictionary = MyDictionary(key)
    Else
        LookupDictionary = key & " : "
    End If
End Function

Sub main()
    On Error Resume Next
    Dim str$
    
    Select Case TypeName(Selection)
    Case "Range"
        str = ActiveCell.Value
    Case "Rectangle", "TextBox"
        str = Selection.Text
    Case Else
        Debug.Print TypeName(Selection)
        Exit Sub
    End Select
    
    With Application
        Dim m As Match
        For Each m In RYAK_PA.Execute(str)
            .StatusBar = LookupDictionary(m.Value)
            Wait 2
        Next
        .StatusBar = False
    End With
End Sub

Function Wait(Optional n As Single = 3) As Single
    Wait = Timer + n
    Do While Wait > Timer
        DoEvents
    Loop
End Function