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

概要

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

イメージ

使用方法

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	選択範囲のセルを、結合セル風に変更(セル値がブランクまたは上部セルと同値の場合、そのセルの値と上罫線を除去)

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

上記ラッパー関数を意識せず自由に作りたい場合は、マクロ追加時に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です。