【VBA】楽するためのマクロ

Option Base 1

Private myInterier As Variant
Private shtHistory As Collection

Private Sub auto_open()
  Application.OnKey "{F1}", ""

  'セル移動
  Application.OnKey "^{k}", "アクティブセル↑"
  Application.OnKey "^{j}", "アクティブセル↓"
  Application.OnKey "^{l}", "アクティブセル→"
  Application.OnKey "^{h}", "アクティブセル←"
 
'  Application.OnKey "^%{UP}", "ウィンドウスクロール↑"
'  Application.OnKey "^%{DOWN}", "ウィンドウスクロール↓"
'  Application.OnKey "^%{RIGHT}", "ウィンドウスクロール→"
'  Application.OnKey "^%{LEFT}", "ウィンドウスクロール←"
  Application.OnKey "^%{k}", "ウィンドウスクロール↑"
  Application.OnKey "^%{j}", "ウィンドウスクロール↓"
  Application.OnKey "^%{l}", "ウィンドウスクロール→"
  Application.OnKey "^%{h}", "ウィンドウスクロール←"
 
  'セル属性操作
  Application.OnKey "%{UP}", "セル内文字位置↑"
  Application.OnKey "%{DOWN}", "セル内文字位置↓"
  Application.OnKey "%{RIGHT}", "セル内文字位置→"
  Application.OnKey "%{LEFT}", "セル内文字位置←"
 
  Application.OnKey "^%{x}", "フォントサイズ増加"
  Application.OnKey "^+{x}", "フォントサイズ減少"
 
  Application.OnKey "^%{s}", "縮小して全体を表示する_toggle"
  Application.OnKey "^%{w}", "折り返して全体を表示する_toggle"

'  Application.OnKey "^%{l}", "格子線"
'  Application.OnKey "^+{l}", "格子線なし"
  Application.OnKey "^%{o}", "外枠線"
  Application.OnKey "^+{o}", "外枠線なし"
  Application.OnKey "^%{\}", "範囲内の縦線を引く"
  Application.OnKey "^+{\}", "範囲内の縦線を削除"
  Application.OnKey "^%{-}", "範囲内の横線を引く"
  Application.OnKey "^+{-}", "範囲内の横線を削除"
 
  Application.OnKey "^%{p}", "セルにパターンを適用_toggle"
  Application.OnKey "^+{p}", "パターンを選択し直して適用"
 
  'レンジオブジェクト操作
  Application.OnKey "^%{c}", "列幅最適化"
  Application.OnKey "^%{m}", "マージ"
  Application.OnKey "^+{m}", "マージ解除"
  Application.OnKey "^%{r}", "行ごとにマージ"
 
  'ウィンドウ操作
  Application.OnKey "^%{f}", "赤字に_toggle"
  Application.OnKey "^%{z}", "ズームアップ"
  Application.OnKey "^+{z}", "ズームダウン"
 
  'コピペ操作
  Application.OnKey "^%{v}", "値貼付け"
  Application.OnKey "^+{v}", "書式貼付け"
 
  'シート操作
  Application.OnKey "^%{RIGHT}", "次のシートへ移動"
  Application.OnKey "^%{LEFT}", "前のシートへ移動"
'  Application.OnKey "^%{n}", "アクティブシートを新規ブックにコピー"

  '印刷
'  Application.OnKey "^%{d}", "一ページに収まるよう"

End Sub

Private Sub 選択セルのアドレスをクリップボードへ()
    Dim text As String
    Dim CB As New DataObject
'DataObjectを使用するには「Microsoft Forms 2.0 Object Library」への参照が必要。
'Visual Basic Editorのメニューから［ツール］→［参照設定］コマンドを選択し［参照設定］ダイアログボックスで
'「Microsoft Forms 2.0 Object Library」にチェックを入れて、［OK］ボタンをクリックし、参照設定を行います。
'「参照可能なライブラリ ファイル」のリストにない場合は、［参照設定］ダイアログボックスで［参照］ボタンをクリックして
'「C:\WINNT(または Windows)\system32\FM20.DLL」を選択します。
   
    text = Selection.Address(False, False)
    With CB
        .SetText text
        .PutInClipboard
    End With
End Sub


Private Sub 選択セルを下へぶつかるまでコピー()
    Selection.Copy
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Resize(Selection.Rows.Count - 1, Selection.Columns.Count).Select
    ActiveSheet.Paste
End Sub


Private Sub 次のシートへ移動()
  With ActiveSheet
    If .Next Is Nothing Then
        Worksheets(1).Activate
    Else
        .Next.Activate
    End If
  End With
End Sub

Private Sub 前のシートへ移動()
  With ActiveSheet
    If .Previous Is Nothing Then
        Worksheets(Worksheets.Count).Activate
    Else
        .Previous.Activate
    End If
  End With
End Sub


Private Sub 列幅最適化()
  Selection.Columns.EntireColumn.AutoFit
End Sub

Private Sub ウィンドウ枠の固定_toggle()
  With ActiveWindow
    .FreezePanes = Not .FreezePanes
  End With
End Sub

Private Sub フォントサイズ増加()
  With Selection.Font
    .Size = .Size + 1
  End With
End Sub

Private Sub フォントサイズ減少()
  With Selection.Font
    If Not .Size = 1 Then
      .Size = .Size - 1
    End If
  End With
End Sub


Private Sub 一ページに収まるよう()
  With ActiveSheet.PageSetup
    .FitToPagesWide = 1
    .FitToPagesTall = 1
  End With
End Sub


Private Sub 行を挿入して上の行をコピー()
  Selection.EntireRow.Insert Shift:=xlDown
  Rows(ActiveCell.row & ":" & ActiveCell.row).Select
  Selection.FillDown
End Sub

Private Sub ズームアップ()
  ActiveWindow.Zoom = ActiveWindow.Zoom + 5
End Sub

Private Sub ズームダウン()
  ActiveWindow.Zoom = ActiveWindow.Zoom - 5
End Sub

Private Sub 自動連番()
  With ActiveCell
    If (.Offset(1, 0).Value = "") Then
      .Formula = "=" & .End(xlUp).Address(False, False) & "+1"
    Else
      .Formula = "=" & .Offset(-1, 0).Address(False, False) & "+1"
    End If
  End With
End Sub

Private Sub 編集後のセル移動()
  With Application
    Select Case .MoveAfterReturnDirection
      Case xlToRight:   ' ↓移動にする
        .MoveAfterReturn = True
        .MoveAfterReturnDirection = xlDown
      Case xlDown:      ' 移動なしにする
        .MoveAfterReturn = False
        .MoveAfterReturnDirection = xlUp  ' dummy else節に入るようにする。
      Case Else:        ' →移動にする
        .MoveAfterReturn = True
        .MoveAfterReturnDirection = xlToRight
    End Select
  End With
End Sub

Private Sub ウィンドウスクロール←()
  If Not (ActiveCell.column = 1) Then
    ActiveWindow.SmallScroll ToRight:=-1
    ActiveCell.Offset(0, -1).Activate
  End If
End Sub

Private Sub ウィンドウスクロール→()
  ActiveWindow.SmallScroll ToRight:=1
  ActiveCell.Offset(0, 1).Activate
End Sub

Private Sub ウィンドウスクロール↑()
  If Not (ActiveCell.row = 1) Then
    ActiveWindow.SmallScroll Up:=1
    ActiveCell.Offset(-1, 0).Activate
  End If
End Sub

Private Sub ウィンドウスクロール↓()
  ActiveWindow.SmallScroll Up:=-1
  ActiveCell.Offset(1, 0).Activate
End Sub

Private Sub アクティブセル←()
  If Not (ActiveCell.column = 1) Then
    ActiveCell.Offset(0, -1).Activate
  End If
End Sub

Private Sub アクティブセル→()
  ActiveCell.Offset(0, 1).Activate
End Sub

Private Sub アクティブセル↑()
  If Not (ActiveCell.row = 1) Then
    ActiveCell.Offset(-1, 0).Activate
  End If
End Sub

Private Sub アクティブセル↓()
  ActiveCell.Offset(1, 0).Activate
End Sub

Private Sub 選択されているセルを含む行を削除する()
  Selection.EntireRow.Delete
End Sub

Private Sub 選択されているセルを含む行で挿入()
  Selection.EntireRow.Insert Shift:=xlDown
End Sub

Private Sub 赤字に_toggle()
  With Selection
    If Not (.Font.ColorIndex = 3) Then
      .Font.ColorIndex = 3
    Else
      .Font.ColorIndex = 0
    End If
  End With
End Sub

Private Sub セルにパターンを適用_toggle()
  On Error Resume Next
  If Not IsArray(myInterier) Then
    myInterier = fUserSelectInterior_PatternDialog
  End If
  With Selection.Interior
    If (.ColorIndex = myInterier(1)) Then
      .ColorIndex = xlNone
    Else
      .ColorIndex = myInterier(1)
      .Pattern = myInterier(2)
      .PatternColorIndex = myInterier(3)
    End If
  End With
End Sub

Private Sub パターンを選択し直して適用()
  On Error Resume Next
  tmp = fUserSelectInterior_PatternDialog
  If IsArray(tmp) Then
    myInterier = tmp
  Else
    Exit Sub
  End If
  Call セルにパターンを適用_toggle
  Set tmp = Nothing
End Sub

Private Sub セル内文字位置↑()
  With Selection
    Select Case .VerticalAlignment
      Case xlTop: .VerticalAlignment = xlBottom
      Case xlCenter: .VerticalAlignment = xlTop
      Case xlBottom: .VerticalAlignment = xlCenter
      Case Else: .VerticalAlignment = xlTop
    End Select
  End With
End Sub

Private Sub セル内文字位置↓()
  With Selection
    Select Case .VerticalAlignment
      Case xlTop: .VerticalAlignment = xlCenter
      Case xlCenter: .VerticalAlignment = xlBottom
      Case xlBottom: .VerticalAlignment = xlTop
      Case Else: .VerticalAlignment = xlBottom
    End Select
  End With
End Sub

Private Sub セル内文字位置→()
  With Selection
    Select Case .HorizontalAlignment
      Case xlLeft: .HorizontalAlignment = xlCenter
      Case xlCenter: .HorizontalAlignment = xlRight
      Case xlRight: .HorizontalAlignment = xlLeft
      Case Else: .HorizontalAlignment = xlRight
    End Select
  End With
End Sub

Private Sub セル内文字位置←()
  With Selection
    Select Case .HorizontalAlignment
      Case xlLeft: .HorizontalAlignment = xlRight
      Case xlCenter: .HorizontalAlignment = xlLeft
      Case xlRight: .HorizontalAlignment = xlCenter
      Case Else: .HorizontalAlignment = xlLeft
    End Select
  End With
End Sub

Private Sub 外枠線()
  With Selection
    .Borders(xlEdgeLeft).LineStyle = xlContinuous
    .Borders(xlEdgeTop).LineStyle = xlContinuous
    .Borders(xlEdgeBottom).LineStyle = xlContinuous
    .Borders(xlEdgeRight).LineStyle = xlContinuous
  End With
End Sub

Private Sub 外枠線なし()
  With Selection
    .Borders(xlEdgeLeft).LineStyle = xlNone
    .Borders(xlEdgeTop).LineStyle = xlNone
    .Borders(xlEdgeBottom).LineStyle = xlNone
    .Borders(xlEdgeRight).LineStyle = xlNone
  End With
End Sub

Private Sub 範囲内の縦線を引く()
  With Selection
    If (.Columns.Count <= 1) Then
      Exit Sub
    End If
    .Borders(xlInsideVertical).LineStyle = xlContinuous
  End With
End Sub

Private Sub 範囲内の縦線を削除()
  With Selection
    If (.Columns.Count <= 1) Then
      Exit Sub
    End If
    .Borders(xlInsideVertical).LineStyle = xlNone
  End With
End Sub

Private Sub 範囲内の横線を引く()
  With Selection
    If (.Rows.Count <= 1) Then
      Exit Sub
    End If
    .Borders(xlInsideHorizontal).LineStyle = xlContinuous
  End With
End Sub

Private Sub 範囲内の横線を削除()
  With Selection
    If (.Rows.Count <= 1) Then
      Exit Sub
    End If
    .Borders(xlInsideHorizontal).LineStyle = xlNone
  End With
End Sub

Private Sub 格子線()
  With Selection
    .Borders.LineStyle = True
    If (.Rows.Count <= 1) Then
      Exit Sub
    End If
    If (.Columns.Count > 1) Then
      .Borders(xlInsideVertical).LineStyle = xlContinuous
      .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    End If
  End With
End Sub

Private Sub 格子線なし()
  Selection.Borders.LineStyle = xlNone
End Sub

Private Sub マージ()
    Selection.MergeCells = True
End Sub

Private Sub マージ解除()
    Selection.MergeCells = False
End Sub

Private Sub 行ごとにマージ()
Application.ScreenUpdating = False
  With Selection
    startrow = .Cells(1).row
    startCol = .Cells(1).column
    endrow = .Cells(.Count).row
    endCol = .Cells(.Count).column
 
    For i = startrow To endrow
      Range(Cells(i, startCol), Cells(i, endCol)).MergeCells = True
      Application.StatusBar = i & "/" & endrow
    Next
  End With
  Application.StatusBar = False
  Application.ScreenUpdating = True
End Sub

Private Sub 縮小して全体を表示する_toggle()
  With Selection
    .WrapText = False
    .ShrinkToFit = Not .ShrinkToFit
  End With
End Sub

Private Sub 折り返して全体を表示する_toggle()
  With Selection
    .WrapText = Not .WrapText
    .ShrinkToFit = False
  End With
End Sub

Private Sub 値貼付け()
  ActiveCell.PasteSpecial Paste:=xlPasteValues
End Sub

Private Sub 書式貼付け()
  ActiveCell.PasteSpecial Paste:=xlPasteFormats
End Sub

Private Sub 改ページ挿入()
    ActiveCell.Rows.Select
    ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
End Sub

Private Sub すべてのシートを選択()
  Sheets.Select
End Sub

Private Sub アクティブシートを新規ブックにコピー()
  With ActiveSheet
    .Copy
  End With
End Sub


Private Sub シート履歴に保存()
  If (shtHistory Is Nothing) Then
    Set shtHistory = New Collection
  End If
  If (shtHistory.Count = 0) Then
    shtHistory.Add Item:=ActiveSheet.Name
  Else
    shtHistory.Add Item:=ActiveSheet.Name, Before:=1
  End If
End Sub

Private Sub シート履歴()
  If (shtHistory Is Nothing) Then
    Set shtHistory = New Collection
  End If
  If (shtHistory.Count = 0) Then
    Exit Sub
  End If
 
  Dim arrShtName As Variant
  arrShtName = fArr_Collection2Array(shtHistory)
End Sub