LoginSignup
1
2
@efficiency

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

Last updated at Posted at 2024-01-25

概要

アドインを活用した自作ショートカットの紹介。
業務効率化におすすめ。
登録方法は下記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
・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 ↩

1
2
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
1
2