ExcelVBAのショートカットキー自動登録ツール(Ctrl+Shift+キー/F1キーで実行可)

# 概要
マクロを自動でショートカットキーに登録できるツールです。
自作ショートカットを極力手間をかけずに作成、登録したい方にオススメです。

# イメージ
![ショートカット.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3682265/04f8d28c-dc9d-0bfb-e7b1-363f570deb37.png)



# 使用方法
1.A列にキーを設定
2.B列に実行したいマクロ名を設定
3.ショートカット再設定ボタンを押す
4.キーを設定したマクロは、Ctrl+Shift+キーで実行可
5.キーを設定しなかったマクロは、F1キーで実行可

# 作成方法
### ①ショートカット一覧
以下はショートカットのサンプルです。
マクロブックの「ショートカット一覧」シートA1セルに、下表を貼り付ければそのまま使用できます。
キーは自由に変更可能です。

|キー|ショートカット名|機能|
|:-:|:-|:-|
R|AddRedFrame|選択範囲に赤太枠の外枠罫線を付与
Q|AddRedFrameShape|選択範囲に赤太枠の外枠図形を付与
　|AdjustMemo|ブック内のメモを一括調整(メモサイズ自動調整、文字スタイル＝Meiryo UI、文字サイズ＝12)
W|ChangeWidth|選択シートの列幅を3に変更
　|CheckInternetHyperlinks|ブック内のインターネットへのハイパーリンクを検索し、結果をクリップボードに格納
P|CopyActiveSheet|選択シートの直後に選択シートのコピーを作成(シート名が数値の場合は連番で作成)
　|DeleteShapesInRange|選択範囲内の図形をまとめて削除
Z|GoToSheet1|始めのシートへ移動
　|I_AddRows|選択範囲(縦に選択)の行間に、指定行数を挿入
　|I_CreateZipWithPassword|圧縮対象のパスを指定、パスワードをMMDD形式で設定、圧縮結果をデスクトップに配置
L|I_GetFileOrDirPathList|指定したフォルダパス内のファイルまたはフォルダパス一覧をクリップボードに保存。サブフォルダも検索するか選択可
K|I_ReplaceInBulk|指定した置換リスト(2列)を元に、指定した範囲の置換対象を連続置換
Y|I_SC_AddString|選択範囲の値の先頭または末尾に指定文字列を連結
J|I_SC_AddValue|選択範囲の値が数値か日付の場合、指定した数値を追加
C|I_SC_ChangeFontColor|選択範囲のセルについて、指定ワードの文字色(１:赤、２:青、3:緑)と太さ(１:太文字、２:そのまま、3:太文字解除)を設定
　|I_SC_InsertDelimiter|選択範囲のセルの値を、指定した区切り文字で連結し、クリップボードに保存
N|I_SC_MakeDir|選択範囲の値を基にフォルダを作成。絶対パスとして扱うか、親フォルダパスを別途指定するか選択可。親フォルダが存在しない場合、再帰処理で自動的に親フォルダも作成
　|I_SC_SearchFiles|Excel系ファイルを開いて、文言を部分一致検索。複数ファイルのどのシートに検索ワードが含まれるか当たりをつける時に使用(F1キー推奨)
T|I_SC_SearchText|選択範囲の値がExcel系以外のファイルパスの場合、そのファイルを対象に文字列検索。大文字小文字は区別せず検索。
　|I_SC_TrimExtraDelimiter|選択範囲のセルの値から、指定した区切り文字の無駄(先頭と末尾と連続)を除去
　|InsertMissingRows|選択範囲の連番に欠番があれば、その分の行を挿入
A|MoveCursorToA1|全シートのカーソルをA1に移動後、始めのシートへ移動
E|PostProcess|後処理(EnableEvents = Trueなど)が実行されなかった時、設定を元に戻すために使用
X|SC_CreateLinks|選択範囲の値がファイル/フォルダパスの場合、ハイパーリンクを作成
F|SC_CreateLinksDisplayFileName|選択範囲の値がファイル/フォルダパスの場合、ハイパーリンクを作成し、ファイル/フォルダ名だけ表示
S|SC_CreateSheetLinks|選択範囲の値がシート名の場合、シートへのハイパーリンクを作成
M|SC_MakeSheets|選択範囲の値の名称のシートをブックの最後尾に一括で追加
U|SC_OpenDir|選択範囲のファイル/フォルダパスを元にフォルダを開く。セル値またはハイパーリンク設定から情報取得。ファイルを直接開きたくない場合に使用
　|SC_OpenFileReadOnly|選択範囲のセルのパスのファイルを読み取り専用で開く(F1キー推奨)
　|ShapeToBlackFrame|選択図形に黒の太枠を付与
　|ShapeToRedFont|選択図形の文字を赤に変更
　|ShapeToRedFrame|選択図形に赤の太枠を付与
D|SR_CopyFileOrDir|選択範囲(2列以上)の1列目のファイル/フォルダパスが存在すればコピーし、2列目以降のファイル/フォルダパスが存在しなければ貼り付け
　|SR_ExportModules|選択範囲(2列)の1列目のマクロブックパスのモジュールを、2列目のフォルダパスに出力(F1キー推奨)
V|StockEvidence|デスクトップ上のエビデンス.xlsx(なければ自動作成)のActiveSheetの最終行+2に貼り付け(画像の貼り付けにおすすめ)
B|StockEvidenceRight|デスクトップ上のエビデンス.xlsx(なければ自動作成)のActiveSheetの最終行、最終列+1に貼り付け(画像の貼り付けにおすすめ)
　|SurroundEquivalentCells|選択範囲のセルを、結合セル風に変更(セル値がブランクまたは上部セルと同値の場合、そのセルの値と上罫線を除去)

:::note info
・SC_を付けると、Selection_to_Cellがループ処理を自動でやってくれます。
・SR_を付けると、Selection_to_Rowがループ処理を自動でやってくれます。
・似た名前のマクロをコピーすると楽です。
:::

:::note warn
上記ラッパー関数を意識せず自由に作りたい場合は、マクロ追加時にSC_やSR_を付与しないことをおすすめします。
:::

### ②モジュール一覧
マクロのサンプルです。

各種モジュールに貼り付ければそのまま使用できます。

#### ThisWorkbook
    Option Explicit
     
    Private Sub Workbook_Open()
        Call SetShortcuts
    End Sub
     
    Private Sub Workbook_BeforeClose(Cancel As Boolean)
        Call ClearAllShortcuts
    End Sub

#### M01_変数
    Option Explicit
     
    'オブジェクト
    Public fso As Object
    Public wsh As Object
    Public wbTmp As Workbook
    Public wsList As Worksheet
     
    'ショートカットキー設定関連
    Public g_NoKeyMacros As Collection 'グローバル変数としてマクロリストを保持
    Public g_ActionName As String 'グローバル変数としてマクロ名を保持
     
    'インプットボックス
    Public g_strIn As String
    Public g_lngIn As Long
    Public g_dblIn As Double
    Public g_colorIn As Long
    Public g_boldIn As Long
     
    '暫定値格納用
    Public g_strTmp As String
    Public g_rowWsList As Long

#### M02_汎用関数
    Option Explicit
     
    Sub PreProcess()
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
            .Calculation = xlCalculationManual
            .Cursor = xlWait
            .DisplayAlerts = False
        End With
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set wsh = CreateObject("WScript.Shell")
    End Sub
     
    Sub PostProcess()
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
            .Calculation = xlCalculationAutomatic
            .Cursor = xlDefault
            .DisplayAlerts = True
        End With
        Set fso = Nothing
        Set wsh = Nothing
    End Sub
     
    Function fncTrimString(str As String, strTrim As String) As String '第一引数の先頭と末尾にある第二引数を除去
        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
        fncTrimString = 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
     
    Function fncGetLastRow(ws As Worksheet, Optional clm As Long) As Long
        If clm <> 0 Then
            fncGetLastRow = ws.Cells(ws.Rows.Count, clm).End(xlUp).row
        Else
            fncGetLastRow = ws.Cells.SpecialCells(xlLastCell).row
        End If
    End Function
     
    Function fncIsCellAddress(strAddress As String) As Boolean
        Dim regex As Object
        Dim match As Object
        
        '正規表現オブジェクトを作成
        Set regex = CreateObject("VBScript.RegExp")
        regex.Pattern = "^[A-Z]+[0-9]+$"
        regex.IgnoreCase = True '大文字小文字を区別しない
        
        '値がアドレス形式かどうかをチェック
        Set match = regex.Execute(strAddress)
        
        '結果に応じて戻り値を設定
        If match.Count <> 0 Then
            fncIsCellAddress = True
        End If
        
        '後処理
        Set regex = Nothing
        Set match = Nothing
    End Function
     
    Function fncSheetExist(wb As Workbook, strSheetName As String) As Boolean
        Dim ws As Worksheet
        For Each ws In wb.Sheets
            If UCase(strSheetName) = UCase(ws.Name) Then
                fncSheetExist = True
                Exit Function
            End If
        Next
    End Function
     
    Function fncIsDuplicateFileOpen(strWbName As String) As Boolean
        Dim wb As Workbook
        For Each wb In Workbooks
            If wb.Name = strWbName Then
                fncIsDuplicateFileOpen = True
                Exit Function
            End If
        Next
    End Function
     
    Function fncTrimOutside(str As String, Optional strTrim1 As String, Optional strTrim2 As String) As String  '第一引数から第二引数以前と第三引数以後を除去
        If InStr(str, strTrim1) And strTrim1 <> "" Then
            str = Right(str, Len(str) - InStrRev(str, strTrim1) + 1 - Len(strTrim1)) 'strTrim1以前カット
        End If
        If InStr(str, strTrim2) And strTrim2 <> "" Then
            str = Left(str, InStr(str, strTrim2) - 1) 'strTrim2以後カット
        End If
        fncTrimOutside = str
    End Function
     
    Function fncIsFileEditable(strFilePath As String) As Boolean
        Dim fileOpen As Integer
        
        'ファイルが存在しない場合、編集可
        If Not fso.FileExists(strFilePath) Then
            fncIsFileEditable = True
        Else
            'ファイルが開けるかを確認
            fileOpen = FreeFile
            On Error Resume Next
            Open strFilePath For Binary Access Read Lock Read As #fileOpen
            
            'エラーがない場合、編集可
            If Err.Number = 0 Then
                fncIsFileEditable = True
            End If
            Close #fileOpen
            On Error GoTo 0
        End If
    End Function

#### M03_ショートカット登録
    Option Explicit
     
    Sub ClearAllShortcuts()
        Dim key As String
        Dim i As Integer
     
        'AからZまでのショートカットを解除
        For i = 65 To 90 'ASCIIコードでA(65)～Z(90)
            key = Chr(i) 'アルファベット文字に変換
            Application.OnKey "^+" & key
        Next i
     
        'F1キーのショートカットも解除
        Application.OnKey "{F1}"
    End Sub
     
    Sub SetShortcuts()
        Dim ws As Worksheet
        Dim lastRow As Long
        Dim i As Long
        Dim key As String
        Dim macroName As String
        Dim noKeyMacros As Collection
     
        '全ショートカットキーを解除
        Call ClearAllShortcuts
     
        'ショートカットキーを設定するシートを指定（必要に応じて変更）
        Set ws = ThisWorkbook.Sheets("ショートカット一覧")
     
        'B列の最終行を取得
        lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).row
     
        'ショートカットが設定されていないマクロ名を管理
        Set noKeyMacros = New Collection
     
        'ショートカットキーを設定
        For i = 2 To lastRow
            key = Trim(ws.Cells(i, "A").Value)
            macroName = Trim(ws.Cells(i, "B").Value)
     
            If macroName <> "" Then
                If key <> "" Then
                    'Ctrl + Shift + 指定されたアルファベットにラッパー関数を割り当て
                    Application.OnKey "^+" & key, "'WrappedMacro """ & macroName & """'"
                Else
                    'ショートカットキーがない場合リストに追加
                    noKeyMacros.Add macroName
                End If
            End If
        Next i
     
        'F1キーに、ショートカットがないマクロ一覧を実行するマクロを割り当て
        If noKeyMacros.Count > 0 Then
            Application.OnKey "{F1}", "RunNoKeyMacros"
            'グローバル変数で管理
            Set g_NoKeyMacros = noKeyMacros
        End If
    End Sub
     
    Sub RunNoKeyMacros()
        Dim i As Long
        Dim macroList As String
        Dim inputNum As String
        Dim selectedMacro As String
        
        On Error GoTo ErrorHandler
     
        'ショートカットが設定されていないマクロのリストを作成
        If g_NoKeyMacros Is Nothing Or g_NoKeyMacros.Count = 0 Then
            MsgBox "実行可能なマクロがありません。"
            Exit Sub
        End If
     
        macroList = "以下のマクロが登録されています:" & vbCrLf
        For i = 1 To g_NoKeyMacros.Count
            macroList = macroList & i & ": " & g_NoKeyMacros(i) & vbCrLf
        Next i
     
        'ユーザーに番号を入力させる
        inputNum = InputBox(macroList & vbCrLf & "実行したいマクロの番号を入力してください:")
     
        '入力が無効の場合
        If Not IsNumeric(inputNum) Or inputNum < 1 Or inputNum > g_NoKeyMacros.Count Then
            MsgBox "無効な入力です。"
            Exit Sub
        End If
     
        '選択されたマクロをラッパー関数で実行
        selectedMacro = g_NoKeyMacros(CLng(inputNum))
        Call WrappedMacro(selectedMacro)
        
        Exit Sub
        
    ErrorHandler:
        MsgBox "エラーが発生しました: " & Err.Description, vbCritical
        Call PostProcess
    End Sub

#### M04_ラッパー関数
    Option Explicit
     
    Sub WrappedMacro(ActionName As String)
        On Error GoTo ErrorHandler
        
        '前処理
        Call PreProcess
        
        '実行するマクロを動的に呼び出し
        g_ActionName = ActionName
        If InStr(g_ActionName, "I_") Then
            Application.Run g_ActionName
        ElseIf InStr(g_ActionName, "SC_") Then
            Call Selection_to_Cell
        ElseIf InStr(g_ActionName, "SR_") Then
            If InStr(g_ActionName, "RV_") Then
                Call Selection_to_Row(, True)
            Else
                Call Selection_to_Row
            End If
        Else
            Application.Run g_ActionName
        End If
        
        '後処理
        Call PostProcess
     
        Exit Sub
     
    ErrorHandler:
        MsgBox "エラーが発生しました: " & Err.Description, vbCritical
        Call PostProcess
    End Sub
     
    Sub Selection_to_Cell(Optional targetRng As Range)
        Dim rng As Range
        Dim cell As Range
     
        '初期処理
        If Not targetRng Is Nothing Then
            Set rng = targetRng
        Else
            Set rng = Selection
        End If
        
        '選択セルを順不同に後続処理に渡す
        For Each cell In rng
            If Not (cell.Value = "" Or cell.EntireRow.Hidden Or cell.EntireColumn.Hidden) Then
                If InStr(g_ActionName, "I_") Then
                    Application.Run Replace(g_ActionName, "I_", ""), cell
                Else
                    Application.Run g_ActionName, cell
                End If
            End If
        Next
     
        '後処理
        Set rng = Nothing
        Set cell = Nothing
        
    End Sub
     
    Sub Selection_to_Row(Optional targetRng As Range, Optional reverse As Boolean = False)
        Dim rng As Range
        Dim ary As Variant
        Dim currentRow As Range
        Dim i As Long
        Dim lngStart As Long
        Dim lngEnd As Long
        Dim lngStep As Long
     
        '初期処理
        If Not targetRng Is Nothing Then
            Set rng = targetRng
        Else
            Set rng = Selection
        End If
        If reverse = False Then
            lngStart = 1
            lngEnd = rng.Rows.Count
            lngStep = 1
        Else
            lngStart = rng.Rows.Count
            lngEnd = 1
            lngStep = -1
        End If
        
        '選択セルの1行分のデータをRangeとして、後続処理に渡す
        For i = lngStart To lngEnd Step lngStep '縦方向
            Set currentRow = rng.Rows(i)
            If InStr(g_ActionName, "I_") Then
                Application.Run Replace(g_ActionName, "I_", ""), currentRow
            Else
                Application.Run g_ActionName, currentRow
            End If
        Next
        
        '後処理
        Set rng = Nothing
        
    End Sub

#### M05_包括処理
    Option Explicit
     
    Sub I_SC_AddValue()
        g_dblIn = InputBox("セルに追加する数値を入力してください。")
        Call Selection_to_Cell
    End Sub
     
    Sub I_SC_AddString()
        g_strIn = InputBox("セルに連結させる文字列を入力してください。")
            If g_strIn = "" Then Exit Sub
        g_lngIn = InputBox("1:先頭に付与、2:末尾に付与")
        Call Selection_to_Cell
    End Sub
     
    Sub I_SC_TrimExtraDelimiter()
        g_strIn = InputBox("余分な区切り文字を入力してください。")
        If g_strIn = "" Then Exit Sub
        Call Selection_to_Cell
    End Sub
     
    Sub I_SC_InsertDelimiter()
        g_strIn = InputBox("区切り文字を入力してください。")
        If g_strIn = "" Then Exit Sub
        g_strTmp = ""
        Call Selection_to_Cell
        g_strTmp = fncTrimString(g_strTmp, g_strIn)
        Call SetClipboard(g_strTmp)
    End Sub
     
    Sub I_SC_MakeDir()
        g_lngIn = InputBox("1:絶対パスでフォルダ作成、2:親フォルダを指定してフォルダ作成")
        If g_lngIn = 1 Then '1の場合、処理進行
        ElseIf g_lngIn = 2 Then
            g_strIn = InputBox("親フォルダパスを入力してください。", , wsh.specialfolders("Desktop"))
            g_strIn = fncTrimString(g_strIn, """")
            If InStr(g_strIn, "\") = 0 Then
                MsgBox "パスが指定されていません。処理を終了します。"
                Exit Sub
            End If
        Else '1,2以外の入力の場合
            MsgBox "1,2のどちらかを指定してください。"
            Exit Sub
        End If
        Call Selection_to_Cell
    End Sub
     
    Sub I_SC_SearchText()
        Dim rng As Range
        Set rng = Selection
        g_strIn = InputBox("検索ワードを入力してください。")
        g_strIn = StrConv(LCase(g_strIn), vbNarrow)
        If g_strIn = "" Then Exit Sub
        Set wsList = ActiveWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
        g_rowWsList = 2
        
        Call Selection_to_Cell(rng)
        
        On Error Resume Next
        wsList.Name = g_strIn '\とかだとエラーが発生する
        On Error GoTo 0
        
        wsList.Cells(1, 1) = "No"
        wsList.Cells(1, 2) = "フォルダパス"
        wsList.Cells(1, 3) = "フルパス"
        wsList.Cells(1, 4) = "ファイル名"
        wsList.Cells(1, 5) = "拡張子"
        wsList.Cells(1, 6) = "行数"
        wsList.Cells(1, 7) = "桁数"
        wsList.Cells(1, 8) = "「" & g_strIn & "」検索結果"
        wsList.Cells(1, 9) = "コメントアウト"
        wsList.Cells(1, 10) = "左辺"
        wsList.Cells(1, 11) = "右辺"
        wsList.Cells(1, 12) = "型"
        wsList.Columns("B:C").ShrinkToFit = True
        wsList.Columns("A:A").EntireColumn.AutoFit
        wsList.Columns("D:H").EntireColumn.AutoFit
        ActiveWindow.SplitRow = 1
        ActiveWindow.FreezePanes = True
        wsList.Cells(1, 1).CurrentRegion.AutoFilter field:=9, Criteria1:=""
        
        Set wsList = Nothing
        
    End Sub
     
    Sub I_SC_SearchFiles()
     
        Dim rng As Range
        Set rng = Selection
        g_strIn = InputBox("検索ワードを入力してください。")
        g_strIn = StrConv(LCase(g_strIn), vbNarrow)
        If g_strIn = "" Then Exit Sub
        Set wsList = ActiveWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
        g_rowWsList = 2
        
        Call Selection_to_Cell(rng)
        
        wsList.Cells(1, 1) = "フォルダ名"
        wsList.Cells(1, 2) = "フルパス"
        wsList.Cells(1, 3) = "シート名"
        wsList.Cells(1, 4) = "「" & g_strIn & "」検索結果"
        
        On Error Resume Next
        wsList.Name = g_strIn
        On Error GoTo 0
        
        Set wsList = Nothing
        Set rng = Nothing
    End Sub
     
    Sub I_SC_ChangeFontColor()
        g_strIn = InputBox("色を変更する文字列を入力してください。")
        g_colorIn = InputBox("色を指定してください。赤：１、青：２、緑：３、黒：４")
        g_boldIn = InputBox("太文字にしますか？太文字：１、そのまま：2、解除：3")
        Call Selection_to_Cell
    End Sub

#### M06_個別処理_Cell
    Option Explicit
     
    Sub SC_CreateLinks(cell As Range)
        If fso.FileExists(cell.Value) Or fso.FolderExists(cell.Value) Then
            ActiveSheet.Hyperlinks.Add anchor:=cell, Address:=cell.Value
        Else
            cell.ClearHyperlinks
            cell.Font.Underline = False
            cell.Font.ColorIndex = xlAutomatic
        End If
    End Sub
     
    Sub SC_CreateSheetLinks(cell As Range)
        ActiveSheet.Hyperlinks.Add anchor:=cell, Address:="", SubAddress:="'" & cell.Value & "'!A1"
    End Sub
     
    Sub SC_CreateLinksDisplayFileName(cell As Range)
        ActiveSheet.Hyperlinks.Add anchor:=cell, Address:=cell.Value, TextToDisplay:=Mid(cell.Value, InStrRev(cell.Value, "\") + 1)
    End Sub
     
    Sub SC_TrimExtraDelimiter(cell As Range)
        Do While Right(cell.Value, 1) = vbLf
            cell.Value = Left(cell.Value, Len(cell.Value) - 1)
        Loop
        Do While InStr(cell.Value, g_strIn & g_strIn)
            cell.Value = Replace(cell.Value, g_strIn & g_strIn, g_strIn)
        Loop
        cell.Value = fncTrimString(cell.Value, g_strIn)
    End Sub
     
    Sub SC_InsertDelimiter(cell As Range)
        g_strTmp = g_strTmp & cell.Value & g_strIn
    End Sub
     
    Sub SC_OpenDir(cell As Range)
        If fso.FolderExists(cell) Then
            Shell "explorer " & fso.GetFolder(cell), vbNormalFocus
        ElseIf fso.FileExists(cell) Then
            Shell "explorer " & fso.GetParentFolderName(cell), vbNormalFocus
        ElseIf fso.FolderExists(cell.Hyperlinks(1).Address) Then
            Shell "explorer " & fso.GetFolder(cell.Hyperlinks(1).Address), vbNormalFocus
        ElseIf fso.FileExists(cell.Hyperlinks(1).Address) Then
            Shell "explorer " & fso.GetParentFolderName(cell.Hyperlinks(1).Address), vbNormalFocus
        Else
            cell.Hyperlinks(1).Follow NewWindow:=False, addhistory:=True
        End If
    End Sub
     
    Sub SC_AddValue(cell As Range)
        cell.Value = cell.Value + g_dblIn
    End Sub
     
    Sub SC_AddString(cell As Range)
        If g_lngIn = 1 Then
            cell.Value = g_strIn & Trim(cell.Text)
        ElseIf g_lngIn = 2 Then
            cell.Value = Trim(cell.Text) & g_strIn
        End If
    End Sub
     
    Sub SC_MakeDir(cell As Range)
        Call MakeDirRecursively(fso.BuildPath(g_strIn, cell.Value))
    End Sub
     
    Sub SC_MakeSheets(cell As Range)
        Worksheets.Add After:=Worksheets(Worksheets.Count)
        On Error Resume Next
        ActiveSheet.Name = cell.Value
        On Error GoTo 0
    End Sub
     
    Sub SC_SearchText(cell As Range)
        Dim strTemp As String
        Dim rowReadText As Long
        
        Open cell.Value For Input As #1
        rowReadText = 1
        Do Until EOF(1)
            Line Input #1, strTemp
            If InStr(StrConv(LCase(strTemp), vbNarrow), g_strIn) <> 0 Then
                wsList.Cells(g_rowWsList, 1) = g_rowWsList - 1
                wsList.Cells(g_rowWsList, 2) = fso.GetParentFolderName(cell.Value)
                wsList.Cells(g_rowWsList, 3) = cell.Value
                wsList.Cells(g_rowWsList, 4) = fso.GetBaseName(cell.Value)
                wsList.Cells(g_rowWsList, 5) = Mid(cell.Value, InStrRev(cell.Value, ".") + 1)
                wsList.Cells(g_rowWsList, 6) = rowReadText
                wsList.Cells(g_rowWsList, 7).Formula2 = "=SEARCH(""" & g_strIn & """,$H" & g_rowWsList & ")"
                wsList.Cells(g_rowWsList, 8) = strTemp
                If Left(Trim(strTemp), 1) = "'" Then
                    wsList.Cells(g_rowWsList, 9) = "コメント"
                End If
                wsList.Cells(g_rowWsList, 10).Formula2 = "=TRIM(TEXTSPLIT($H" & g_rowWsList & ",""=""))"
                If InStr(strTemp, " As ") Then
                    wsList.Cells(g_rowWsList, 12) = Trim(fncTrimOutside(fncTrimOutside(strTemp, " As ", "'"), , ")"))
                Else
                    wsList.Cells(g_rowWsList, 12) = "なし"
                End If
                g_rowWsList = g_rowWsList + 1
            End If
            rowReadText = rowReadText + 1
        Loop
        Close #1
        
    End Sub
     
    Sub SC_SearchFiles(cell As Range)
        Dim rngFind As Range
        Dim j As Long
        
        If fso.FileExists(cell.Value) Then
            Set wbTmp = Workbooks.Open(Filename:=cell.Value, UpdateLinks:=0)
            For j = 1 To wbTmp.Worksheets.Count
                Set rngFind = wbTmp.Sheets(j).Cells.Find(What:=g_strIn, LookAt:=xlPart, MatchCase:=False)
                If Not rngFind Is Nothing Then
                    wsList.Cells(g_rowWsList, 1) = fso.GetParentFolderName(cell.Value)
                    wsList.Cells(g_rowWsList, 2) = cell.Value
                    wsList.Cells(g_rowWsList, 3) = wbTmp.Sheets(j).Name
                    wsList.Cells(g_rowWsList, 4) = rngFind.Value
                    g_rowWsList = g_rowWsList + 1
                End If
            Next
            wbTmp.Close
        End If
        
        Set rngFind = Nothing
        Set wbTmp = Nothing
    End Sub
     
    Sub SC_OpenFileReadOnly(cell As Range)
        If fso.FileExists(cell) Then
            Workbooks.Open Filename:=cell, ReadOnly:=True
        ElseIf fso.FileExists(cell.Hyperlinks(1).Address) Then
            Workbooks.Open Filename:=cell.Hyperlinks(1).Address, ReadOnly:=True
        End If
    End Sub
     
    Sub SC_ChangeFontColor(cell As Range)
        Dim lngStart As Long
    '    lngStart = InStr(cell.Value, g_strIn) '大文字小文字区別あり
        lngStart = InStr(UCase(cell.Value), UCase(g_strIn)) '大文字小文字区別なし
        If lngStart >= 1 Then
            If g_colorIn = 1 Then
                cell.Characters(start:=lngStart, Length:=Len(g_strIn)).Font.ColorIndex = 3 '赤
            ElseIf g_colorIn = 2 Then
                cell.Characters(start:=lngStart, Length:=Len(g_strIn)).Font.ColorIndex = 5 '青
            ElseIf g_colorIn = 3 Then
                cell.Characters(start:=lngStart, Length:=Len(g_strIn)).Font.ColorIndex = 4 '緑
            ElseIf g_colorIn = 4 Then
                cell.Characters(start:=lngStart, Length:=Len(g_strIn)).Font.ColorIndex = 1 '黒
            End If
            If g_boldIn = 1 Then
                cell.Characters(start:=lngStart, Length:=Len(g_strIn)).Font.bold = True
            ElseIf g_boldIn = 3 Then
                cell.Characters(start:=lngStart, Length:=Len(g_strIn)).Font.bold = False
            End If
        End If
    End Sub

#### M07_個別処理_Row
    Option Explicit
     
    Sub SR_CopyFileOrDir(rowRange As Range)
        Dim j As Long
        For j = 2 To rowRange.Columns.Count 'リストの横方向
            If rowRange.Cells(1, 1) = "" Or rowRange.Cells(1, j) = "" Then '空文字はskip
            ElseIf fso.FileExists(rowRange.Cells(1, 1)) Then 'コピー元ファイルが存在し、コピー先が存在しなければコピー、それ以外はスキップ
                If Not fso.FileExists(rowRange.Cells(1, j)) Then
                    fso.CopyFile rowRange.Cells(1, 1), rowRange.Cells(1, j)
                End If
            ElseIf fso.FolderExists(rowRange.Cells(1, 1)) Then 'コピー元フォルダが存在し、コピー先が存在しなければコピー、それ以外はスキップ
                If Not fso.FolderExists(rowRange.Cells(1, j)) Then
                    fso.CopyFolder rowRange.Cells(1, 1), rowRange.Cells(1, j)
                End If
            End If
        Next
    End Sub
     
    Sub SR_ExportModules(rowRange As Range)
        Dim filePath As String
        Dim folderPath As String
        Dim vbComp As Object
        Dim vbProj As Object
        Dim wb As Workbook
        Dim codeContent As String
        
        If Not fso.FileExists(rowRange.Cells(1, 1)) Then
            'ファイルが存在しない場合はskip
        ElseIf Not fso.FolderExists(rowRange.Cells(1, 2)) Then
            '保存先フォルダが存在しない場合はskip
        Else
            filePath = rowRange.Cells(1, 1)
            folderPath = rowRange.Cells(1, 2)
            If Right(folderPath, 1) <> "\" Then
                folderPath = folderPath & "\"
            End If
            Set wb = Workbooks.Open(Filename:=filePath, UpdateLinks:=0)
            If wb.VBProject.Protection = 1 Then
                Stop
            End If
            Set vbProj = wb.VBProject
            For Each vbComp In vbProj.VBComponents
                If vbComp.CodeModule.CountOfLines > 0 Then
                    codeContent = vbComp.CodeModule.Lines(1, vbComp.CodeModule.CountOfLines)
                Else
                    codeContent = ""
                End If
                codeContent = Replace(codeContent, vbCrLf, "")
                If codeContent <> "Option Explicit" And codeContent <> "" Then
                    vbComp.Export folderPath & vbComp.Name & ".bas"
                End If
            Next vbComp
            wb.Close SaveChanges:=False
        End If
        Set wb = Nothing
    End Sub

#### M08_個別処理_その他
    Option Explicit
     
    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 InsertMissingRows()
        Dim i As Long
        Dim j As Long
        Dim topRow As Long
        Dim lastRow As Long
        Dim startNm As Long
        Dim cnt As Long
        Dim clm As Long
        topRow = Selection.row
        lastRow = Selection.Rows.Count + Selection.row - 1
        clm = Selection.Column
        For i = lastRow To topRow Step -1
            If i = 1 Then
            ElseIf IsNumeric(Cells(i, clm)) And IsNumeric(Cells(i - 1, clm)) Then
                If Int(Cells(i, clm)) <> Int(Cells(i - 1, clm)) + 1 Then
                    cnt = Int(Cells(i, clm)) - Int(Cells(i - 1, clm)) - 1
                    For j = 1 To cnt
                        Rows(i).Insert
                    Next
                End If
            End If
        Next
    End Sub
     
    Sub ChangeWidth()
        ActiveSheet.Cells.Select
        Selection.ColumnWidth = 3
        ActiveSheet.Range("A1").Select
    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 ShapeToRedFrame()
        Selection.ShapeRange.Fill.Visible = msoFalse
        With Selection.ShapeRange.Line
            .ForeColor.RGB = RGB(255, 0, 0)
            .Weight = 2.25
        End With
    End Sub
     
    Sub ShapeToRedFont()
        Selection.ShapeRange.Fill.Visible = msoFalse
        Selection.ShapeRange.Line.Visible = msoFalse
        With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill
            .Visible = msoTrue
            .ForeColor.RGB = RGB(255, 0, 0)
        End With
    End Sub
     
    Sub ShapeToBlackFrame()
        With Selection.ShapeRange.Line
            .Visible = msoTrue
            .ForeColor.ObjectThemeColor = msoThemeColorText1
        End With
    End Sub
     
    Sub ShapeToRedFrameWhiteBack()
        With Selection.ShapeRange.Fill
            .Visible = msoTrue
            .ForeColor.ObjectThemeColor = msoThemeColorBackground1
        End With
        With Selection.ShapeRange.Line
            .Visible = msoTrue
            .ForeColor.RGB = RGB(255, 0, 0)
            .Weight = 2.25
        End With
        With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill
            .Visible = msoTrue
            .ForeColor.RGB = RGB(255, 0, 0)
        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 I_GetFileOrDirPathList()
        Dim strin As String
        Dim strPathList As String
        Dim lngIn As Long
     
        strin = InputBox("パス一覧を取得するフォルダパスを入力してください。")
        strin = fncTrimString(strin, """")
        If strin = "" Then Exit Sub
        lngIn = InputBox("1:Fileパス一覧" & vbLf & "2:Fileパス一覧(サブフォルダ含む)" & vbLf & "3:Dirパス一覧" & vbLf & "4:Dirパス一覧(サブフォルダ含む)")
        If lngIn = 1 Or lngIn = 2 Or lngIn = 3 Or lngIn = 4 Then
            Call GetPathListRecursively(strin, strPathList, lngIn)
            strPathList = fncTrimString(strPathList, vbLf)
            Call SetClipboard(strPathList)
        End If
     
    End Sub
     
    Sub GetPathListRecursively(dirParh As String, strPathList As String, lngIn As Long)
        Dim tmpFile
        Dim tmpDir
        If fso.FolderExists(dirParh) Then
            Select Case lngIn
            Case 1, 2
                For Each tmpFile In fso.GetFolder(dirParh).Files
                    strPathList = strPathList & tmpFile.Path & vbLf
                Next
            Case 3, 4
                For Each tmpDir In fso.GetFolder(dirParh).SubFolders
                    strPathList = strPathList & tmpDir.Path & vbLf
                Next
            End Select
            If lngIn = 2 Or lngIn = 4 Then
                For Each tmpDir In fso.GetFolder(dirParh).SubFolders
                    Call GetPathListRecursively(tmpDir.Path, strPathList, lngIn)
                Next
            End If
        Else
            MsgBox "subGetPathListRecursively に 存在しない dirParh が渡されました。"
        End If
    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 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 I_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
        For i = lastRow To topRow + 1 Step -1
            For j = 1 To cntAddRows
                Rows(i).Insert
            Next
        Next
    End Sub
     
    Sub I_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
        
        Call PostProcess
        
        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 PreProcess
        
        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
                            rngList(k, 1).Offset(0, 2).Value = rngList(k, 1).Offset(0, 2).Value + 1 '暫定
                        End If
                    Next
                End If
            Next
        Next
        rngReplace = aryReplace
        MsgBox cnt & "件置換しました。"
    finally:
        Set rngList = Nothing
        Set rngReplace = Nothing
    End Sub
     
    Sub AdjustMemo()
        Dim rng As Range
        Dim ws As Worksheet
        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
    End Sub
     
    Sub SurroundEquivalentCells()
        Dim i As Long
        Dim j As Long
        Dim topRow As Long
        Dim lastRow As Long
        Dim topClm As Long
        Dim lastClm As Long
     
        topRow = Selection.row
        lastRow = Selection.Rows.Count + Selection.row - 1
        topClm = Selection.Column
        lastClm = Selection.Columns.Count + Selection.Column - 1
        For i = lastRow To topRow Step -1
            If i >= 2 Then
                For j = topClm To lastClm
                    If ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i - 1, j).Value Or ActiveSheet.Cells(i, j).Value = "" Then
                        ActiveSheet.Cells(i, j).Value = ""
                        ActiveSheet.Cells(i, j).Borders(xlEdgeTop).LineStyle = xlNone
                    End If
                Next
            End If
        Next
    End Sub
     
    Sub OpenEvidence()
        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
     
    Sub MakeDirRecursively(strPath As String)
     
        Dim parentDirPath As String '親フォルダパス
     
        strPath = Trim(strPath)
        parentDirPath = Trim(fso.GetParentFolderName(strPath))
     
        'フォルダが存在する場合、または引数が空文字の場合、Exit
        If fso.FolderExists(strPath) Or strPath = "" Then
            Exit Sub
        'フォルダが存在しない場合
        Else
            '親フォルダが存在しない場合、親フォルダ作成のため再帰呼び出し
            If Not fso.FolderExists(parentDirPath) Then
                Call MakeDirRecursively(parentDirPath)
            End If
            fso.CreateFolder strPath
        End If
     
    End Sub
     
    Sub I_CreateZipWithPassword()
        Dim exe7zip As String
        Dim zipFilePath As String
        Dim passWord As String
        Dim execCommand As String
        Dim result As Integer
        Dim desktopPath As String
        Dim strin As String
        Dim i As Long
        strin = InputBox("圧縮対象のパスを入力してください。")
        strin = fncTrimString(strin, """")
        
        desktopPath = wsh.specialfolders("Desktop")
        
        '7z.exeのパスを指定 ※パスにスペースが含まれているため、「""」で囲んでいます。
        exe7zip = """C:\Program Files\7-Zip\7z.exe"""
        '作成するZIPファイルのパスを指定
        zipFilePath = desktopPath & "\" & fso.GetBaseName(strin) & ".zip"
        'パスワードを指定
        passWord = Format(Now, "mmdd")
        '圧縮コマンドを組み立て
        execCommand = exe7zip & " a -ssw -p" & passWord & " " & zipFilePath & " " & strin
        '圧縮コマンドを実行
        result = wsh.Run(Command:=execCommand, WindowStyle:=0, WaitOnReturn:=True)
        
    End Sub

### ③ショートカット再設定ボタン
ボタンにはSetShortcutsを登録すればOKです。