【VBA】XLSTART 個人用マクロ

AttachKey

``` AttachKey
'^:Ctrl
'%:Alt
'+:Shift

Sub auto_open()
'ショートカット割り当て
    Application.OnKey "{F1}", ""                                'F1を押してもヘルプを表示させない
'■■■■■■■■■■
'■  Ctrl + Alt    ■
'■■■■■■■■■■
    'フォント
    Application.OnKey "^%{UP}", "IncreaseFontSize"              'Ctrl + Alt + ↑　フォントサイズ　＋１ポイント
    Application.OnKey "^%{DOWN}", "DecreaseFontSize"            'Ctrl + Alt + ↓　フォントサイズ　－１ポイント
    'セル書式設定
    Application.OnKey "^%{LEFT}", "SwitchVerticalAlignment"     'Ctrl + Alt + ←　縦位置切り替え
    Application.OnKey "^%{RIGHT}", "SwitchHorizontalAlignment"  'Ctrl + Alt + →　横位置切り替え
    'オブジェクト
    Application.OnKey "^%,", "SendSpaheToFront"                 'Ctrl + Alt + ,　 オブジェクトを最前面に移動
    Application.OnKey "^%.", "SendSpaheToBack"                  'Ctrl + Alt + .　 オブジェクトを最背面に移動
    Application.OnKey "^%/", "ChangeShapeSelectMode"            'Ctrl + Alt + /   オブジェクトの選択モード
    Application.OnKey "^%m", "GroupUngroupShape"                'Ctrl + Alt + M   オートシェイプグループ化
    
    'ツール
    Application.OnKey "^%q", "GetWorkSheetNames"                'Ctrl + Alt + Q   シート一覧をInputBoxに表示
    Application.OnKey "^%w", "SetFormatConditions"              'Ctrl + Alt + W   条件付き書式(True→緑、False→赤)
    Application.OnKey "^%a", "SetCursorHome"                      'Ctrl + Alt + A   各シートの選択セルを"A1"に変更
    
    
'■■■■■■■■■■
'■  Ctrl + Shift  ■
'■■■■■■■■■■
    '罫線
    Application.OnKey "^+q", "DrawGrid"                         'Ctrl + Shift + Q　 罫線
    Application.OnKey "^+w", "DrawGridAround"                   'Ctrl + Shift + W　 罫線：枠
    Application.OnKey "^+e", "DeleteGrid"                       'Ctrl + Shift + E　 罫線無し
    Application.OnKey "^+r", "DrawGridTable"                    'Ctrl + Shift + R　 罫線：表
    
    'セル結合
    Application.OnKey "^+a", "CellMergeUnMerge"                 'Ctrl + Shift + A　 選択セルの結合と結合解除
    Application.OnKey "^+s", "MergeUnMergeSide"                 'Ctrl + Shift + S　 選択セルの横方向の結合と結合解除
    
    'セルコピー
    Application.OnKey "^+d", "CopyCellFontWhite"                'Ctrl + Shift + D　 セルコピー + 2行目以降のフォントカラー白
    
    '行／列操作
    Application.OnKey "^+f", "InsertLine"                       'Ctrl + Shift + F 　行挿入
    Application.OnKey "^+g", "InsertLineEachRows"               'Ctrl + Shift + G 　一行置きに行挿入
    Application.OnKey "^+h", "DeleteLine"                       'Ctrl + Shift + H 　行削除
    
    ' オブジェクト
    Application.OnKey "^+z", "AddShapeRectangle"                'Ctrl + Shift + Z 　枠
    Application.OnKey "^+x", "AddShapeConnextor"                'Ctrl + Shift + X   矢印
    Application.OnKey "^+c", "AddShapeCircle"                   'Ctrl + Shift + C   楕円
    Application.OnKey "^+v", "AddShapeCallout"                  'Ctrl + Shift + V 　吹き出し
    
    'フォント
    Application.OnKey "^+1", "SwitchFontColor"                  'Ctrl + Shift + 1　 フォントカラースイッチ 自動/赤/白
    
    'セル バッググラウンドカラー変更
    Application.OnKey "^+2", "SwitchInteriorColor"               'Ctrl + Shift + 2  塗りつぶし：なし
    Application.OnKey "^+3", "'SetBGColor 0'"                    'Ctrl + Shift + 3  塗りつぶし：オレンジ
    Application.OnKey "^+4", "'SetBGColor 1'"                    'Ctrl + Shift + 4  塗りつぶし：青色
    Application.OnKey "^+5", "'SetBGColor 2'"                    'Ctrl + Shift + 5  塗りつぶし：緑色
    Application.OnKey "^+6", "'SetBGColor 3'"                    'Ctrl + Shift + 6  塗りつぶし：黄色
    Application.OnKey "^+7", "'SetBGColor 4'"                    'Ctrl + Shift + 7  塗りつぶし：黒色
    
    
'■■■■■■■■■■■■■
'■  Ctrl + Shift + ALT  ■
'■■■■■■■■■■■■■
    Application.OnKey "^+%r", "基本設計書_ズーム改ページ"
    Application.OnKey "^+%f", "showSearchBox"                    'Ctrl + Shift + Alt + F  検索ボックス表示
    Application.OnKey "^+%l", "ResetFilter"                      'Ctrl + Shift + Alt + l  フィルタの絞り込みを解除
    
End Sub


```

modCommon
```
'-------------------------------------------
' 画面更新抑止/イベント発生抑止/関数手動計算
'-------------------------------------------
Public Sub InvalidExcelEvents()
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
End Sub

'-------------------------------------------
' 画面更新抑止解除/イベント発生抑止解除/関数自動計算
'-------------------------------------------
Public Sub ValidExcelEvents()
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub
'--------------------------------------
'フォルダを選択ダイアログを表示
'選択されたフォルダのフルパスを返却
'--------------------------------------
Public Function FolderPicker()
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            FolderPicker = .SelectedItems(1)
        Else
            End
        End If
        
    End With
End Function



```


modPaste
```
'■■■■■■■■■■■■■■■■■■■■■
'■  ペースト系
'■■■■■■■■■■■■■■■■■■■■■

'-------------
' 値の貼り付け
'-------------
Sub PasteValue()
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End Sub

'-------------
' 書式の貼り付け
'-------------
Sub PasteFormats()
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End Sub

'--------------------------
'行列を入れ替えて貼り付け
'--------------------------
Sub PaseteValueRotate()
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End Sub



```

modRange
```
'■■■■■■■■■■■■■■■■■■■■■
'■  セル
'■■■■■■■■■■■■■■■■■■■■■
Sub CellMergeUnMerge()
'-------------
'セル結合・解除
'-------------
    On Error GoTo MyError
    With Selection
        If .MergeCells = False Then
            .MergeCells = True
        Else
            .MergeCells = False
        End If
    End With
MyError:
End Sub
Sub MergeUnMergeSide()
'-------------
'横方向に結合・解除
'-------------
    On Error GoTo MyError
    With Selection
        If .MergeCells = False Then
            .Merge True
        Else
            .MergeCells = False
        End If
    End With
MyError:
End Sub
Sub CopyTopMergedCellToUnderCell()
'--------------------------------------
'Ctrl + D の結合セル対応版
'--------------------------------------
    Range(Cells(Selection.Row, Selection.Column), Cells(Selection.Row, Selection(Selection.Count).Column)).Copy
    Range(Cells(Selection.Row + 1, Selection.Column), Cells(Selection(Selection.Count).Row, Selection(Selection.Count).Column)).PasteSpecial
    Application.CutCopyMode = False
End Sub

Sub CopyCellFontWhite()
'--------------------------------------
'Ctrl + D の2行目以降のフォントカラー白
'--------------------------------------
    Range(Cells(Selection.Row, Selection.Column), Cells(Selection.Row, Selection(Selection.Count).Column)).Copy
    Range(Cells(Selection.Row + 1, Selection.Column), Cells(Selection(Selection.Count).Row, Selection(Selection.Count).Column)).PasteSpecial
    Range(Cells(Selection.Row + 1, Selection.Column), Cells(Selection(Selection.Count).Row, Selection(Selection.Count).Column)).Font.Color = RGB(255, 255, 255)
    Application.CutCopyMode = False

End Sub

Sub SwitchVerticalAlignment()
'--------------------------------------
'セル縦位置切り替え
'--------------------------------------
    With Selection
        If .VerticalAlignment = xlTop Then
            .VerticalAlignment = xlCenter
        ElseIf .VerticalAlignment = xlCenter Then
            .VerticalAlignment = xlBottom
        Else
            .VerticalAlignment = xlTop
        End If
    End With
End Sub
Sub SwitchHorizontalAlignment()
'--------------------------------------
'セル横位置切り替え
'--------------------------------------
    With Selection
        If .HorizontalAlignment = xlDistributed Then
            .HorizontalAlignment = xlLeft
        ElseIf .HorizontalAlignment = xlLeft Then
            .HorizontalAlignment = xlCenter
        ElseIf .HorizontalAlignment = xlCenter Then
            .HorizontalAlignment = xlRight
        Else
            .HorizontalAlignment = xlDistributed
        End If
    End With
End Sub

Sub SwitchWrapText()
'--------------------------------------
'折り返し表示切り替え
'--------------------------------------
    With Selection
        If .WrapText = True Then
            .WrapText = False
        Else
            .WrapText = True
        End If
    End With
End Sub

'■■■■■■■■■■■■■■■■■■■■■
'■  セル バックグラウンドカラー設定
'■■■■■■■■■■■■■■■■■■■■■
Sub SetBGColor(vKey)
'------------------
'カラーセット入口
'------------------
    Const vDefTandS = 1
    vTandS = vDefTandS
    vTintAndShade = Array(0, 0.4, 0.6)
    vXlThemeColor = Array(xlThemeColorAccent2, xlThemeColorAccent1, xlThemeColorAccent6, xlThemeColorAccent4, xlThemeColorLight1)
    If IsNull(GetBGColorTheme) Or IsNull(GetBGColorTintAndShade) Or (GetBGColorTheme = -4142) Then
        vTandS = vTintAndShade(vDefTandS)
    Else
        If vXlThemeColor(vKey) = GetBGColorTheme Then
            vTandS = TintAndShadeRotate(GetBGColorTintAndShade)
        Else
            vTandS = vTintAndShade(vDefTandS)
        End If
    End If
    Call SetBGColors(vTintAndShade(vTandS), vXlThemeColor(vKey))
End Sub
Sub SetBGColors(vTintAndShade, vXlThemeColor)
'------------------
'選択セルの色セット
'濃度
'テーマ
'------------------
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = vXlThemeColor
        .TintAndShade = vTintAndShade
        .PatternTintAndShade = 0
    End With
End Sub
Function TintAndShadeRotate(vTandS)
'------------------
'濃度ローテート
'------------------
    If vTandS >= 2 Then
        TintAndShadeRotate = 0
    Else
        TintAndShadeRotate = vTandS + 1
    End If
End Function
Function GetBGColorTheme()
'------------------
'選択セルのカラーテーマ取得
'------------------
    With Selection.Interior
        GetBGColorTheme = .ThemeColor
        
    End With
End Function
Function GetBGColorTintAndShade()
'------------------
'選択セルの色濃度取得
'------------------
    vTintAndShade = Array(0, 0.4, 0.6)
    vCelTintAndShade = Selection.Interior.TintAndShade
    For i = 0 To 2
        If Round(vCelTintAndShade, 2) = vTintAndShade(i) Then
            Exit For
        End If
    Next
    GetBGColorTintAndShade = i
End Function

Sub SwitchInteriorColor()
'------------------
'塗りつぶし色切り替え なし→黄色→なし
'------------------
    If Selection.Interior.ColorIndex = xlNone Then
        Selection.Interior.Color = RGB(255, 255, 0)
    Else
        Selection.Interior.ColorIndex = xlNone
    End If
    
End Sub

'■■■■■■■■■■■■■■■■■■■■■
'■  行／列操作
'■■■■■■■■■■■■■■■■■■■■■
Sub InsertLine()
'--------------------------
'行挿入
'--------------------------
    Selection.EntireRow.Insert
End Sub
Sub InsertLineEachRows()
'--------------------------
'一行置きに行挿入
'--------------------------
    For i = Selection(Selection.Count).Row To Selection(1).Row Step -1
        Rows(i + 1).Insert
    Next i
End Sub
Sub DeleteLine()
'--------------------------
'行挿入
'--------------------------
    Selection.EntireRow.DELETE
End Sub
Sub AdjustSelectionRows()
'--------------------------
'選択範囲の行幅を自動調整する
'--------------------------
    For i = Selection(Selection.Count).Row To Selection(1).Row Step -1
        Rows(i + 1).Insert
    Next i
End Sub
'■■■■■■■■■■■■■■■■■■■■■
'■  フォント
'■■■■■■■■■■■■■■■■■■■■■
Sub SwitchFontColor()
'--------------------------------------
'フォント色切り替え 自動→赤色→白色→自動
'--------------------------------------
    If Selection.Font.ColorIndex = xlAutomatic Or Selection.Font.ColorIndex = 1 Then
        Selection.Font.Color = RGB(255, 0, 0)
    ElseIf Selection.Font.ColorIndex = 3 Then
        Selection.Font.Color = RGB(255, 255, 255)
    Else
        Selection.Font.ColorIndex = xlAutomatic
    End If
End Sub
Sub IncreaseFontSize()
'--------------------------------------
'フォントサイズ大きく
'--------------------------------------
    With Selection.Font
        .size = .size + 1
        If .size > 300 Then
            .size = 300
        End If
    End With
End Sub
Sub DecreaseFontSize()
'--------------------------------------
'フォントサイズ小さく
'--------------------------------------
    With Selection.Font
        If .size >= 2 Then
            .size = .size - 1
        End If
    End With
End Sub




```

modTools
```

'■■■■■■■■■■■■■■■■■■■■■
'■  ツール
'■■■■■■■■■■■■■■■■■■■■■
Sub SetCursorHome()
'--------------------------------------
'各シートの選択セルを"A1"に変更
'--------------------------------------
    Dim s As Object
    For Each s In ActiveWorkbook.Sheets
        s.Activate
        'SendKeys "^{HOME}"
        Application.GoTo Range("A1"), True
    Next s
    Sheets(1).Select
End Sub

Sub GetWorkSheetNames()
'--------------------------------------
'各シート名をClipboard にコピー
'--------------------------------------
    Dim targetWorkSheet As Worksheet
    Dim workSheetNames As String
    Dim CB As New DataObject
    For Each targetWorkSheet In Sheets
        workSheetNames = workSheetNames & targetWorkSheet.Name & vbCrLf
    Next
    With CB
        .SetText workSheetNames
        .PutInClipboard
    End With
End Sub

```

modShape
```

'■■■■■■■■■■■■■■■■■■■■■
'■  オートシェイプ
'■■■■■■■■■■■■■■■■■■■■■
Sub GroupUngroupShape()
'--------------------------
'オートシェイプグループ化・解除
'--------------------------
    Dim sType: sType = TypeName(Selection)
    If sType = "DrawingObjects" Then
        Selection.ShapeRange.Group.Select
    ElseIf sType = "GroupObject" Then
        Selection.ShapeRange.Ungroup.Select
    End If
End Sub

Sub ChangeShapeSelectMode()
'--------------------------
'オブジェクトの選択モードにする
'--------------------------
    With Application.CommandBars.FindControl(id:=182)
        If .State = msoButtonUp Then .Execute
    End With
End Sub
Sub SendSpaheToFront()
'--------------------------
'オートシェイプを最前面に移動する
'--------------------------
    Dim sType: sType = TypeName(Selection)
    If sType <> "Range" Then
        Selection.ShapeRange.ZOrder msoBringToFront
    End If
End Sub
Sub SendSpaheToBack()
'--------------------------
'オートシェイプを最背面に移動する
'--------------------------
    Dim sType: sType = TypeName(Selection)
    If sType <> "Range" Then
        Selection.ShapeRange.ZOrder msoSendToBack
    End If
End Sub
Sub AddShapeCallout()
'--------------------------------------
'オートシェイプ：吹き出しを追加
'--------------------------------------
    Dim MyShape As Shape
    Set MyShape = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangularCallout, 1, 1, 180, 54)
    With MyShape.Fill
         .Visible = msoTrue
         .ForeColor.RGB = RGB(255, 255, 255)
         .Transparency = 0
         .Solid
     End With
     With MyShape.TextFrame2.TextRange.Font
         .Fill.Visible = msoTrue
         .Fill.ForeColor.RGB = RGB(0, 0, 0)
         .Name = "Meiryo UI"
         .NameFarEast = "Meiryo UI"
         .NameComplexScript = "Meiryo UI"
         .Fill.Transparency = 0
         .Fill.Solid
     End With
     With MyShape.Line
         .Visible = msoTrue
         .ForeColor.RGB = RGB(255, 0, 0)
         .Transparency = 0
     End With
     With MyShape.TextFrame
         .HorizontalAlignment = xlGeneral
         .VerticalAlignment = xlVAlignCenter
     End With
     With MyShape.Adjustments
        .Item(1) = -0.66596
        .Item(2) = 0.48952
    End With
    With MyShape
        .Top = ActiveCell.Top
        .Left = ActiveCell.Left
    End With
End Sub

Sub AddShapeCircle()
'--------------------------------------
'オートシェイプ：楕円を追加
'--------------------------------------
    Dim MyShape As Shape
    Set MyShape = ActiveSheet.Shapes.AddShape(msoShapeOval, 1, 1, 60, 30)
    MyShape.Fill.Visible = msoFalse
    With MyShape.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
    End With
    With MyShape
        .Top = ActiveCell.Top
        .Left = ActiveCell.Left
    End With
End Sub

Sub AddShapeRectangle()
'--------------------------------------
'オートシェイプ：楕円を追加
'--------------------------------------
    Dim MyShape As Shape
    Set MyShape = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 1, 1, 110, 30)
    MyShape.Fill.Visible = msoFalse
    With MyShape.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
    End With
    With MyShape
        .Top = ActiveCell.Top
        .Left = ActiveCell.Left
    End With
End Sub

Sub AddShapeConnextor()
'--------------------------------------
'オートシェイプ：矢印を追加
'--------------------------------------
    Dim MyShape As Shape
    Set MyShape = ActiveSheet.Shapes.AddConnector(msoConnectorElbow, 1, 1, 70, 50)
    MyShape.Fill.Visible = msoFalse
    With MyShape.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
        .Weight = 1.25
        .EndArrowheadStyle = msoArrowheadTriangle
    End With
    With MyShape
        .Top = ActiveCell.Top
        .Left = ActiveCell.Left
    End With
End Sub

```

Utils
```

'--------------------------------------
'最終行を取得(xlDown)
'--------------------------------------
Public Function GetEndRowXLDOWN(ByVal aSheetName As String, ByVal aCol As Long, ByVal aRow) As Long
    GetEndRow = Worksheets(aSheetName).Cells(aRow, aCol).End(xlDown).Row
    If GetEndRow < aMinRow Then
        GetEndRow = aMinRow
    End If
End Function
'--------------------------------------
'最終行を取得(xlUp)
'--------------------------------------
Public Function GetEndRowXLUP(ByVal aSheetName As String, ByVal aCol As Long, Optional ByVal aMinRow As Long = 1) As Long
    GetEndRow = Worksheets(aSheetName).Cells(Rows.Count, aCol).End(xlUp).Row
    If GetEndRow < aMinRow Then
        GetEndRow = aMinRow
    End If
End Function
'--------------------------------------
'1列目からパラメータ列までの列幅を取得
'--------------------------------------
Public Function GetTotalColumnWidth(ByVal aSheetName As String, ByVal aCol As Long) As Double
    Dim TotalColumnWidth As Double
    For i = 1 To aCol
        TotalColumnWidth = TotalColumnWidth + Worksheets(aSheetName).Columns(i).ColumnWidth
    Next
    GetTotalColumnWidth = TotalColumnWidth
End Function
'--------------------------------------
'1列目からパラメータ列までの列幅を取得(単位：ピクセル)
'--------------------------------------
Public Function GetTotalColumnWidthPixel(ByVal aSheetName As String, ByVal aCol As Long) As Double
    Dim TotalColumnWidthPixel As Double
    For i = 1 To aCol
        TotalColumnWidthPixel = TotalColumnWidthPixel + Worksheets(aSheetName).Columns(i).width
    Next
    GetTotalColumnWidthPixel = TotalColumnWidthPixel
End Function
'--------------------------------------
'1行目からパラメータ行までの行幅を取得
'--------------------------------------
Public Function GetTotalRowHeight(ByVal aSheetName As String, ByVal aRow As Long)
    Dim TotalRowHeight As Double
    For i = 1 To aRow
        TotalRowHeight = TotalRowHeight + Worksheets(aSheetName).Rows(i).RowHeight
    Next
    GetTotalRowHeight = TotalRowHeight

End Function
'--------------------------------------
'セルが選択されているかどうかを判定する
'true:セルが選択されている
'false:セルが選択されていない
'--------------------------------------
Public Function isCell(aSelection) As Boolean
    Dim sType: sType = TypeName(aSelection)
    If (sType <> "Range") Then
        isCell = False
        Exit Function
    End If
    isCell = True
End Function

'-------------------------------------------
' Null/Emptyチェック
' @param sVal チェック対象文字列
' @return Null/Emptyの場合はTrue
'-------------------------------------------
Public Function IsNullOrEmpty(ByVal sVal As Variant) As Boolean
    If IsNull(sVal) Or IsEmpty(sVal) Or sVal = "" Then IsNullOrEmpty = True
End Function
'-------------------------------------------
' パラメータ文字列の両端にシングルクォーテーション付与
' @param sVal 文字列
' @return '文字列'
'-------------------------------------------
Public Function AttachSinglequotation(ByVal sVal As String) As String
    AttachSinglequotation = Chr(39) & sVal & Chr(39)
End Function
'-------------------------------------------
' パラメータ文字列の両端にダブルクォーテーション付与
' @param sVal 文字列
' @return "文字列"
'-------------------------------------------
Public Function AttachDoublequotation(ByVal sVal As String) As String
    AttachDoublequotation = Chr(34) & sVal & Chr(34)
End Function
'-------------------------------------------
' パラメータ文字列の両端に括弧付与
' @param sVal 文字列
' @return (文字列)
'-------------------------------------------
Public Function AttachBrackets(ByVal sVal As String) As String
    AttachBrackets = Chr(40) & sVal & Chr(41)
End Function

```

modGrid
```
'■■■■■■■■■■■■■■■■■■■■■
'■  罫線
'■■■■■■■■■■■■■■■■■■■■■

'-------------
'罫線
'-------------
Sub DrawGrid()
    Selection.Borders.LineStyle = xlContinuous
End Sub

'-------------
'罫線無し
'-------------
Sub DeleteGrid()
    Selection.Borders.LineStyle = xlLineStyleNone
End Sub

'-------------
'罫線:枠
'-------------
Sub DrawGridAround()
    Selection.BorderAround Weight:=xlThin, ColorIndex:=1
End Sub

'-------------
'罫線:表
'-------------
Sub DrawGridTable()
    Selection.Borders.LineStyle = xlContinuous
    With Selection.Rows(1).Borders(xlEdgeBottom)
        .LineStyle = xlDouble
        .ColorIndex = 0
        .TintAndShade = 0
    End With
End Sub
```