Excelにブックマーク機能を追加するマクロ

エクセルのジャンプ機能

エクセルには名前の定義やジャンプといった機能があり、これらを使うことで特定のセルに移動することができます。

裏を返せば、特定のセルにジャンプするためには「名前の定義」を行うしかありません。この機能を使うとワークシート関数などにも影響してしまうため、安易に追加・削除を繰り返すことはできません。

したがって、後で確認したいセルなどがある場合は、マクロを使って「ブックマーク」を作成するのが効果的です。

マクロの要件

必要となるマクロ

次の2つのマクロが必要になります。

• 選択中のセル（または何らかのセル）をブックマークに登録するマクロ
• ブックマーク一覧を表示するユーザーフォーム

ユーザーフォームの要件

ブックマークに登録するマクロは、非常にシンプルに書けますから、考えることはあまりありません。

ユーザーフォームに求められる要件は次のとおりでしょう。

• ブックマークを一覧できる
• ブックマークに容易にジャンプできる
• ブックマークを削除できる

サンプルコード

ブックマークへの登録とユーザーフォームの呼び出し

Sub Add_Bookmark()
' Hotkey: Ctrl + F6
' Onkey: "^{F6}"
' 選択中のセルをブックマークに登録する。ブックマークの一覧は、Alt + F6 でよびだせる。

    Dim bookmark_name As String
    Dim bookmark_address As String
    
    bookmark_name = Application.InputBox(prompt:="Bookmark Name:", Title:="Add Selection to Bookmark")
    If bookmark_name = False Then Exit Sub
        
    bookmark_address = ActiveSheet.Name & "!" & Selection.address
    
    ' アクティブワークシートのThisworkbookモジュールに、正規表現でアドレスを追加
    With ActiveWorkbook.VBProject.VBComponents("Thisworkbook").CodeModule
        .InsertLines .CountOfLines + 1, "'Bookmark\" & bookmark_name & "\" & bookmark_address
    End With

End Sub

Sub Bookmark_Manager()
' Hotkey: Alt + F6
' Onkey: "%{F6}"
    UFM_BOOKMARK.Show
End Sub

ユーザーフォーム

Option Explicit

Private Sub UserForm_Initialize()
    
    Dim i As Integer
    With UFM_BOOKMARK
        
        .StartUpPosition = 2
        .Width = 500
        .Height = 300
        .Caption = "Search Bookmarks - Productivity Package"
        
        With .Label1
            .Top = 10
            .Left = 10
            .Width = 280
            .Height = 15
            .Font.Size = 10
            .Caption = "Find bookmarks named:"
        End With
    
        With .TextBox1
            .Top = 25
            .Left = 10
            .Width = 400
            .Height = 20
            .Font.Size = 10
            .SpecialEffect = fmSpecialEffectEtched
            .SetFocus
        End With
        
        With .CommandButton1
            .Top = 25
            .Left = 420
            .Width = 60
            .Height = 20
            .Font.Size = 10
            .Caption = "Find"
            .Accelerator = "F"
            .TabStop = False
        End With
        
        With .Label2
            .Top = 55
            .Left = 10
            .Width = 400
            .Height = 15
            .Font.Size = 10
            .Caption = "Select from the list and jump to selected range (Press Ecs to exit)"
        End With
        
        With .CommandButton2
            .Top = 70
            .Left = 420
            .Width = 60
            .Height = 20
            .Font.Size = 10
            .Caption = "Delete"
            .Accelerator = "D"
            .TabStop = False
        End With
    
        With .ListBox1
            .Top = 70
            .Left = 10
            .Width = 400
            .Height = 200
            .ColumnCount = 2
            .Font.Size = 10
            .SpecialEffect = fmSpecialEffectEtched
                        
            .AddItem
            .List(0, 0) = "Current Range"
            .List(0, 1) = ActiveSheet.Name & "!" & Selection.address
            
            Dim code_module As Object
            Dim i_list As Integer
            Dim i_line As Integer, tmp_line As String
            
            Set code_module = ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
            i_list = 1
            
            For i_line = 1 To code_module.CountOfLines
                tmp_line = code_module.Lines(i_line, 1)
                If tmp_line Like "'Bookmark\*" Then
                    .AddItem
                    .List(i_list, 0) = Split(tmp_line, "\")(1)
                    .List(i_list, 1) = Split(tmp_line, "\")(2)
                    i_list = i_list + 1
                End If
            Next i_line
            
        End With
        
    End With

End Sub

Private Sub CommandButton1_Click()
    Call Refresh_ListBox(UFM_BOOKMARK.TextBox1.Text)
    With UFM_BOOKMARK.ListBox1
        If .ListCount > 0 Then
            .SetFocus
            .ListIndex = 0
        End If
        UFM_BOOKMARK.Label1.Caption = .ListCount & " bookmark(s) is found."
    End With
End Sub

Private Sub CommandButton2_Click()
        
    If MsgBox(prompt:="Are you sure to delete this bookmark?", _
              Buttons:=vbExclamation + vbYesNo + vbDefaultButton2, _
              Title:="Bookmark Manager") _
            = vbNo Then
        UFM_BOOKMARK.ListBox1.SetFocus
        Exit Sub
    End If
    
    Dim line_value As String
    With UFM_BOOKMARK.ListBox1
        line_value = "'Bookmark\" & .List(.ListIndex, 0) & "\" & .List(.ListIndex, 1)
        .RemoveItem .ListIndex
        .SetFocus
    End With
        
    Dim i As Integer
    With ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
        For i = 1 To .CountOfLines
            If .Lines(i, 1) = line_value Then .DeleteLines i, 1
        Next i
    End With
    
End Sub

Private Sub ListBox1_Change()
    On Error Resume Next
    
    Dim sheet_name As String
    Dim range_address As String
    
    With UFM_BOOKMARK.ListBox1
        sheet_name = Split(.List(.ListIndex, 1), "!")(0)
        range_address = Split(.List(.ListIndex, 1), "!")(1)
    End With
        
    Worksheets(sheet_name).Activate
    Range(range_address).Select
    
End Sub

Private Sub ListBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If KeyAscii = vbKeyEscape Then Unload UFM_BOOKMARK
End Sub

Private Sub Refresh_ListBox(Optional search_keyword As String)

    ' Normalize search_keyword
    If IsMissing(search_keyword) = True Then
        search_keyword = "**"
    Else
        search_keyword = "*" & search_keyword & "*"
    End If
    
    ' Declaration
    Dim code_module As Object
    Dim line_count As Integer
    Dim i_list As Integer
    Dim i_line As Integer
    Dim tmp_line As String
        
    Set code_module = ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
    line_count = code_module.CountOfLines
    i_list = 0
    
    With UFM_BOOKMARK.ListBox1
        .Clear
        For i_line = 1 To line_count
            tmp_line = code_module.Lines(i_line, 1)
            If tmp_line Like search_keyword And tmp_line Like "'Bookmark\*" Then
                .AddItem
                .List(i_list, 0) = Split(tmp_line, "\")(1)
                .List(i_list, 1) = Split(tmp_line, "\")(2)
                i_list = i_list + 1
            End If
        Next i_line
    End With
    
End Sub