ExcelVBAの自作ショートカット一覧(Ctrl+Shift+キーで実行可)

# 概要
アドインを活用した自作ショートカットの紹介。
業務効率化におすすめ。
登録方法は下記VBAコードの貼り付けでOK。

# 使用方法
Excel上でCtrl+Shift+キーで実行

# ショートカット一覧
|キー|ショートカット名|機能|
|:-:|:-|:-|
X|CreateLinks|選択範囲の値が『ファイルパス/フォルダパス/URL』の場合、ハイパーリンクを作成
S|CreateSheetLinks|選択範囲の値が『シート名』の場合、シートへのハイパーリンクを作成
F|CreateLinksDisplayFileName|選択範囲の値が『ファイルパス/フォルダパス』の場合、ハイパーリンクを作成し、『ファイル名/フォルダ名』だけ表示
A|MoveCursorToA1|全シートのカーソルをA1に移動後、Sheet1へ移動
Z|GoToSheet1|Sheet1へ移動
G|GroupColumns|選択列をグループ化(行全体を選択状態の場合は選択行をグループ化)
H|UngroupColumns|選択列のグループ化を解除(行全体を選択状態の場合は選択行のグループを解除)
W|ChangeWidth|選択シートの列幅を3に変更
T|TrimExtraDelimiter|選択範囲のセルの値から、指定した区切り文字の無駄(先頭と末尾と連続)を除去
R|AddRedFrame|選択範囲に赤太枠の罫線を付与
Q|AddRedFrameShape|選択範囲に赤太枠の図形を付与
L|GetFilePathList|指定したフォルダパス内のファイルパス一覧をクリップボードに保存
I|InsertDelimiter|選択範囲のセルの値を、指定した区切り文字で連結し、クリップボードに保存
V|StockEvidence|デスクトップ上のエビデンス.xlsx(なければ自動作成)のActiveSheetの最終行+2に貼り付け(画像の貼り付けにおすすめ)
B|StockEvidenceRight|デスクトップ上のエビデンス.xlsx(なければ自動作成)のActiveSheetの最終行、最終列+1に貼り付け(画像の貼り付けにおすすめ)
U|OpenURL|選択範囲のURLのリンクを一括で開く
M|MakeSheets|選択範囲の値の名称のシートをブックの最後尾に一括で追加
P|CopyActiveSheet|選択シートの直後にシートのコピーを作成(シート名が数値の場合は連番で作成)
E|DeleteShapesInRange|選択範囲内の図形をまとめて削除
N|AddRows|選択範囲内の行ごとに、指定した数の新規行を追加
K|ReplaceInBulk|指定した置換リスト(2列)を元に、指定した範囲の置換対象を一括置換
J|AddValue|選択範囲のセルの値が数値か日付の場合、指定した値を追加
Y|AddString|選択範囲のセルに、セルの表示文字列と指定文字列を連結して入力
O|AdjustMemo|ブック内のメモを一括調整(メモサイズ自動調整、文字スタイル＝Meiryo UI、文字サイズ＝12)

# 登録方法(簡略版)
アドインに以下のコードを貼り付け
・[ThisWorkbook](#thisworkbook)
・[Module1](#module1)

# 登録方法(詳細版)
①Excelの新規ブックを開く(Ctrl+n)
②名前を付けて保存(F12キー)
・ファイルの種類：『Excelアドイン(.xlam)』
・ファイル名：☆ショートカット
③Excel画面→開発タブ [^1] →『Excelアドイン』→☆ショートカットにチェック→OK
④VBEを開く(Alt＋F11)
⑤プロジェクトエクスプローラーを開く(Ctrl+r)
⑥『VBAProject(☆ショートカット.xlam)』を全展開→ThisWorkbookをダブルクリック→開かれた画面に以下のコードを貼り付け

### 【ThisWorkbook】

    Option Explicit
    
    Private Sub workbook_Open()
        'ショートカットキー設定
        Application.OnKey "^+x", "CreateLinks" '[Ctrl]+[Shift]+[x]
        Application.OnKey "^+s", "CreateSheetLinks" '[Ctrl]+[Shift]+[s]
        Application.OnKey "^+f", "CreateLinksDisplayFileName" '[Ctrl]+[Shift]+[f]
        Application.OnKey "^+a", "MoveCursorToA1" '[Ctrl]+[Shift]+[a]
        Application.OnKey "^+z", "GoToSheet1" '[Ctrl]+[Shift]+[z]
        Application.OnKey "^+g", "GroupColumns" '[Ctrl]+[Shift]+[g]
        Application.OnKey "^+h", "UngroupColumns" '[Ctrl]+[Shift]+[h]
        Application.OnKey "^+w", "ChangeWidth" '[Ctrl]+[Shift]+[w]
        Application.OnKey "^+t", "TrimExtraDelimiter" '[Ctrl]+[Shift]+[t]
        Application.OnKey "^+r", "AddRedFrame" '[Ctrl]+[Shift]+[r]
        Application.OnKey "^+q", "AddRedFrameShape" '[Ctrl]+[Shift]+[q]
        Application.OnKey "^+l", "GetFilePathList" '[Ctrl]+[Shift]+[l]
        Application.OnKey "^+i", "InsertDelimiter" '[Ctrl]+[Shift]+[i]
        Application.OnKey "^+v", "StockEvidence" '[Ctrl]+[Shift]+[v]
        Application.OnKey "^+b", "StockEvidenceRight" '[Ctrl]+[Shift]+[b]
        Application.OnKey "^+u", "OpenURL" '[Ctrl]+[Shift]+[u]
        Application.OnKey "^+m", "MakeSheets" '[Ctrl]+[Shift]+[m]
        Application.OnKey "^+p", "CopyActiveSheet" '[Ctrl]+[Shift]+[p]
        Application.OnKey "^+e", "DeleteShapesInRange" '[Ctrl]+[Shift]+[e]
        Application.OnKey "^+n", "AddRows" '[Ctrl]+[Shift]+[n]
        Application.OnKey "^+k", "ReplaceInBulk" '[Ctrl]+[Shift]+[k]
        Application.OnKey "^+j", "AddValue" '[Ctrl]+[Shift]+[j]
        Application.OnKey "^+y", "AddString" '[Ctrl]+[Shift]+[y]
        Application.OnKey "^+o", "AdjustMemo" '[Ctrl]+[Shift]+[o]
    End Sub
    
    Private Sub Workbook_BeforeClose(Cancel As Boolean)
        'ショートカットキー解除
        Application.OnKey "^+x" '[Ctrl]+[Shift]+[x]
        Application.OnKey "^+s" '[Ctrl]+[Shift]+[s]
        Application.OnKey "^+f" '[Ctrl]+[Shift]+[f]
        Application.OnKey "^+a" '[Ctrl]+[Shift]+[a]
        Application.OnKey "^+z" '[Ctrl]+[Shift]+[z]
        Application.OnKey "^+g" '[Ctrl]+[Shift]+[g]
        Application.OnKey "^+h" '[Ctrl]+[Shift]+[h]
        Application.OnKey "^+w" '[Ctrl]+[Shift]+[w]
        Application.OnKey "^+t" '[Ctrl]+[Shift]+[t]
        Application.OnKey "^+r" '[Ctrl]+[Shift]+[r]
        Application.OnKey "^+q" '[Ctrl]+[Shift]+[q]
        Application.OnKey "^+l" '[Ctrl]+[Shift]+[l]
        Application.OnKey "^+i" '[Ctrl]+[Shift]+[i]
        Application.OnKey "^+v" '[Ctrl]+[Shift]+[v]
        Application.OnKey "^+b" '[Ctrl]+[Shift]+[b]
        Application.OnKey "^+u" '[Ctrl]+[Shift]+[u]
        Application.OnKey "^+m" '[Ctrl]+[Shift]+[m]
        Application.OnKey "^+p" '[Ctrl]+[Shift]+[p]
        Application.OnKey "^+e" '[Ctrl]+[Shift]+[e]
        Application.OnKey "^+n" '[Ctrl]+[Shift]+[n]
        Application.OnKey "^+k" '[Ctrl]+[Shift]+[k]
        Application.OnKey "^+j" '[Ctrl]+[Shift]+[j]
        Application.OnKey "^+y" '[Ctrl]+[Shift]+[y]
        Application.OnKey "^+o" '[Ctrl]+[Shift]+[o]
    End Sub

⑦『VBAProject(☆ショートカット.xlam)』を右クリック→挿入→標準モジュール
⑧自動的に開かれた『Module1』の画面に以下のコードを貼り付け

### 【Module1】

    Option Explicit
    
    Sub CreateLinks()
        Dim cell As Range
        For Each cell In Selection
            If Not IsEmpty(cell) Then
                ActiveSheet.Hyperlinks.Add anchor:=cell, Address:=cell.Value
            End If
        Next
    End Sub
    
    Sub CreateSheetLinks()
        Dim cell As Range
        For Each cell In Selection
            If Not IsEmpty(cell) Then
                ActiveSheet.Hyperlinks.Add anchor:=cell, Address:="", SubAddress:="'" & cell.Value & "'!A1"
            End If
        Next
    End Sub
        
    Sub CreateLinksDisplayFileName()
        Dim cell As Range
        For Each cell In Selection
            If Not IsEmpty(cell) Then
                ActiveSheet.Hyperlinks.Add anchor:=cell, Address:=cell.Value, TextToDisplay:=Mid(cell.Value, InStrRev(cell.Value, "\") + 1)
            End If
        Next
    End Sub
    
    Sub MoveCursorToA1()
        Dim ws As Worksheet
        For Each ws In ActiveWorkbook.Sheets
            ws.Activate
            ws.Range("A1").Activate
            ActiveWindow.ScrollRow = ws.Range("A1").Row
            ActiveWindow.ScrollColumn = ws.Range("A1").Column
        Next
        ActiveWorkbook.Sheets(1).Activate
    End Sub
    
    Sub GoToSheet1()
        ActiveWorkbook.Sheets(1).Activate
    End Sub
        
    Sub GroupColumns()
        Selection.Columns.Group
    End Sub
        
    Sub UngroupColumns()
        Selection.Columns.Ungroup
    End Sub
    
    Sub ChangeWidth()
        ActiveSheet.Cells.Select
        Selection.ColumnWidth = 3
        ActiveSheet.Range("A1").Select
    End Sub
    
    Sub TrimExtraDelimiter()
        Dim cell As Range
        Dim strIn As String
        strIn = InputBox("余分な区切り文字を入力してください。")
        For Each cell In Selection
            If Not IsEmpty(cell) Then
                Do While Right(cell.Value, 1) = vbLf
                    cell.Value = Left(cell.Value, Len(cell.Value) - 1)
                Loop
                Do While InStr(cell.Value, strIn & strIn)
                    cell.Value = Replace(cell.Value, strIn & strIn, strIn)
                Loop
                cell.Value = TrimString(cell.Value, strIn)
            End If
        Next
    End Sub
    
    Sub AddRedFrame()
        With Selection.Borders(xlEdgeLeft)
            .Color = -16776961
            .Weight = xlMedium
        End With
        With Selection.Borders(xlEdgeTop)
            .Color = -16776961
            .Weight = xlMedium
        End With
        With Selection.Borders(xlEdgeBottom)
            .Color = -16776961
            .Weight = xlMedium
        End With
        With Selection.Borders(xlEdgeRight)
            .Color = -16776961
            .Weight = xlMedium
        End With
    End Sub
    
    Sub AddRedFrameShape()
        Dim iShapeCd As Integer
        Dim sShape As Shape
        iShapeCd = msoShapeRectangle
        With Selection
            Set sShape = ActiveSheet.Shapes.AddShape(iShapeCd, .Left, .Top, .Width, .Height)
            sShape.Fill.Visible = msoFalse
            sShape.Line.ForeColor.RGB = RGB(255, 0, 0)
            sShape.TextFrame2.TextRange.Characters.Font.Fill.ForeColor.RGB = RGB(255, 0, 0)
            sShape.Line.Weight = 2.25
        End With
    End Sub
    
    Sub GetFilePathList()
        Dim fso
        Dim strIn As String
        Dim strFile
        Dim strFileList As String
        Set fso = CreateObject("Scripting.FileSystemObject")
        strIn = InputBox("フォルダパスを入力してください。")
        strIn = TrimString(strIn, """")
        For Each strFile In fso.getfolder(strIn).Files
            strFileList = strFileList & strFile & vbLf
        Next
        strFileList = TrimString(strFileList, vbLf)
        Call SetClipboard(strFileList)
        Set fso = Nothing
    End Sub
    
    Sub InsertDelimiter()
        Dim cell As Range
        Dim delimiter As String
        Dim str As String
        delimiter = InputBox("区切り文字を入力してください。")
        For Each cell In Selection
            If Not IsEmpty(cell) Then
                str = str & cell.Value & delimiter
            End If
        Next
        str = TrimString(str, delimiter)
        Call SetClipboard(str)
    End Sub
    
    Sub StockEvidence()
        Dim endRow As Long
        Dim clm As Long
        Dim shp As Shape
        Call OpenEvidence
        
        On Error Resume Next
        For Each shp In ActiveSheet.Shapes
            endRow = Application.Max(endRow, shp.BottomRightCell.Row)
        Next
        On Error GoTo 0
        
        For clm = 1 To 256
            endRow = Application.Max(endRow, ActiveSheet.Cells(65536, clm).End(xlUp).Row)
        Next
        ActiveSheet.Paste Destination:=ActiveSheet.Cells(endRow + 2, 1)
        ActiveSheet.Cells(endRow + 2, 1).Activate
    End Sub
    
    Sub StockEvidenceRight()
        Dim endRow As Long
        Dim endClm As Long
        Dim shp As Shape
        Call OpenEvidence
        
        On Error Resume Next
        For Each shp In ActiveSheet.Shapes
            endRow = Application.Max(endRow, shp.TopLeftCell.Row)
        Next
        On Error GoTo 0
        
        endRow = Application.Max(endRow, ActiveSheet.Cells(65536, 1).End(xlUp).Row)
        endClm = ActiveSheet.Cells(endRow, 256).End(xlToLeft).Column
        For Each shp In ActiveSheet.Shapes
            If endRow = shp.TopLeftCell.Row Then
                endClm = Application.Max(endClm, shp.BottomRightCell.Column)
            End If
        Next
        ActiveSheet.Paste Destination:=ActiveSheet.Cells(endRow, endClm + 1)
        ActiveSheet.Cells(endRow, endClm + 1).Activate
    End Sub
    
    Sub OpenURL()
        Dim cell As Range
        For Each cell In Selection
            If Not (IsEmpty(cell) Or cell.EntireRow.Hidden Or cell.EntireColumn.Hidden) Then
                cell.Hyperlinks(1).Follow NewWindow:=False, addhistory:=True
            End If
        Next
    End Sub
    
    Sub MakeSheets()
        Dim cell As Range
        Call Acceleration
        For Each cell In Selection
            If Not IsEmpty(cell) Then
                Worksheets.Add after:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = cell.Value
            End If
        Next
        Call Unacceleration
    End Sub
    
    Sub CopyActiveSheet()
        Dim strNm As String
        strNm = ActiveSheet.Name
        ActiveSheet.Copy after:=ActiveSheet
        On Error Resume Next
        If IsNumeric(strNm) Then 'もしシート名が数値ならシート名を連番で作成
            strNm = Val(strNm) + 1
            ActiveSheet.Name = strNm
        End If
        On Error GoTo 0
    End Sub
    
    Sub DeleteShapesInRange()
        Dim sShape As Object
        For Each sShape In ActiveSheet.Shapes
            If Not Intersect(sShape.TopLeftCell, Selection) Is Nothing Then
                sShape.Delete
            End If
        Next
    End Sub
    
    Sub AddRows()
        Dim i As Long
        Dim j As Long
        Dim topRow As Long
        Dim lastRow As Long
        Dim cntAddRows As Long
        cntAddRows = Int(InputBox("追加行数を入力してください。"))
        topRow = Selection.Row
        lastRow = Selection.Rows.Count + Selection.Row - 1
        Call Acceleration
        For i = lastRow To topRow Step -1
            For j = 1 To cntAddRows
                Rows(i).Insert
            Next
        Next
        Call Unacceleration
    End Sub
    
    Sub ReplaceInBulk()
        Dim rngList As Range
        Dim rngReplace As Range
        Dim aryList As Variant
        Dim aryReplace As Variant
        Dim i As Long
        Dim j As Long
        Dim k As Long
        Dim cnt As Long
        On Error GoTo finally
        Set rngList = Application.InputBox(prompt:="置換リストを置換前と置換後の2列で指定してください。", Type:=8)
        If rngList.Columns.Count <> 2 Then
            MsgBox "置換リストは置換前と置換後の2列で指定してください。"
            Exit Sub
        ElseIf rngList.Areas.Count <> 1 Then
            MsgBox "複数範囲が指定されています。一つの範囲を指定してください。"
            Exit Sub
        End If
        Set rngReplace = Application.InputBox(prompt:="置換したいセル範囲を指定してください。", Type:=8)
        If rngReplace.Areas.Count <> 1 Then
            MsgBox "複数範囲が指定されています。一つの範囲を指定してください。"
            Exit Sub
        End If
        Call Acceleration
        aryList = rngList.Value
        aryReplace = rngReplace.Value
        
        cnt = 0
        For i = LBound(aryReplace) To UBound(aryReplace)
            For j = LBound(aryReplace, 2) To UBound(aryReplace, 2)
                If aryReplace(i, j) <> "" Then
                    For k = LBound(aryList) To UBound(aryList)
                        If aryList(k, 1) <> "" And InStr(aryReplace(i, j), aryList(k, 1)) > 0 Then
                            aryReplace(i, j) = Replace(aryReplace(i, j), aryList(k, 1), aryList(k, 2))
                            cnt = cnt + 1
                        End If
                    Next
                End If
            Next
        Next
        rngReplace = aryReplace
        MsgBox cnt & "件置換しました。"
    finally:
        Call Unacceleration
        Set rngList = Nothing
        Set rngReplace = Nothing
    End Sub
    
    Sub AddValue()
        Dim cell As Range
        Dim dblAddValue As Double
        dblAddValue = InputBox("セルに追加する数値を入力してください。")
        Call Acceleration
        For Each cell In Selection
            If Not IsEmpty(cell) And (IsNumeric(cell)) Or (IsDate(cell)) Then
                cell.Value = cell.Value + dblAddValue
            End If
        Next
        Call Unacceleration
    End Sub
    
    Sub AddString()
        Dim cell As Range
        Dim str As String
        str = InputBox("セルの末尾に連結させる文字列を入力してください。")
        Call Acceleration
        For Each cell In Selection
            cell.Value = Trim(cell.Text) & str
        Next
        Call Unacceleration
    End Sub
    
    Sub AdjustMemo()
        Dim rng As Range
        Dim ws As Worksheet
        Call Acceleration
        On Error Resume Next
        For Each ws In ActiveWorkbook.Sheets
            For Each rng In ws.Cells.SpecialCells(xlCellTypeComments)
                With rng.Comment.Shape.TextFrame
                    .AutoSize = True
                    .Characters.Font.Size = 12
                    .Characters.Font.Name = "Meiryo UI"
                End With
            Next
        Next
        On Error GoTo 0
        Call Unacceleration
    End Sub
    
    Function TrimString(str As String, strTrim As String) As String 'strの先頭と末尾にあるstrTrimを除去
        If Left(str, Len(strTrim)) = strTrim Then
            str = Right(str, Len(str) - Len(strTrim))
        End If
        If Right(str, Len(strTrim)) = strTrim Then
            str = Left(str, Len(str) - Len(strTrim))
        End If
        TrimString = str
    End Function
    
    Sub SetClipboard(ByVal str As String)
        With CreateObject("Forms.TextBox.1")
            .MultiLine = True
            .Text = str
            .selstart = 0
            .sellength = .textlength
            .Copy
        End With
    End Sub
    
    Sub Acceleration()
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
            .Calculation = xlCalculationManual
            .Cursor = xlWait
        End With
    End Sub
    
    Sub Unacceleration()
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
            .Calculation = xlCalculationAutomatic
            .Cursor = xlDefault
        End With
    End Sub
    
    Sub OpenEvidence()
        Dim wsh As Object
        Dim desktopPath As String
        Dim filePath As String
        Set wsh = CreateObject("WScript.Shell")
        desktopPath = wsh.specialfolders("Desktop")
        filePath = desktopPath & "\エビデンス.xlsx"
        If Dir(filePath) <> "" Then
            Workbooks.Open filePath
        Else
            Workbooks.Add
            ActiveWorkbook.SaveAs filePath
        End If
        Set wsh = Nothing
    End Sub
    
⑨『VBAProject(☆ショートカット.xlam)』を保存(Ctrl+s)
⑩VBEの画面とExcelを全て閉じて、任意のExcelを開けば、自作ショートカットが使えるようになっている

[^1]:開発タブが表示されていない場合、ファイルタブ→その他のオプション→オプション→リボンのユーザー設定→画面右側の『開発』にチェック→OK