Excelスターターキットのマクロ化(&クイックアクセスツールバー設定)

1.概要

「シートや行・列の非表示がないかのチェック」「フォントを揃える」など、特に他の人からExcelを引き継いだ場合にやっておきたい処理を自動化することを目的にしたマクロを作成しましたので、備忘として残しておきます。

処理内容

サンプルコードでは下記すべて入れてますが、お好みに合わせて適宜削除してご活用ください(グリッド線などは好みなので

• 非表示シートを再表示させる
• 非表示の列・行を再表示させる
• グリッド線を消す
• フォントを統一する（下記コードでは「Meiryo UI」に変更)
• カーソルをA1に移動
• 表示倍率を100%に変更
• 1枚目のシートに移動して終了

※処理内容それぞれについては過去数多の人が残してくださっているものを参考にさせていただいております。

220425更新

保護されているシートが入っていた際にエラーとなることに気づいたため修正しました。
(保護されているシートについては処理をスキップするようにしましたので、変更したくないシートは保護していただければと思います。)

2.コード部分(結論を急ぐ人向け)

Sub 最初にやるマクロ()
'
' 最初にやるマクロ Macro
'
' 画面更新をさせない（チカチカするため）
Application.ScreenUpdating = False
Dim ws As Worksheet
' 各シートを順番に見ていく
For Each ws In Worksheets
' 非表示のシートを強制的に表示させる
    ws.Visible = True
' シート保護されてるか確認
If ws.ProtectContents = True Then
'保護されてたら何もしない
Else
'保護されていなかったら処理を走らせる
' 行&列について非表示のものを表示させる
    With ws.Rows
        .Hidden = False
    End With
    With ws.Columns
        .Hidden = False
    End With
' グリッド消す
    ActiveWindow.DisplayGridlines = False
' フォントを「Meiryo UI」に変える
    With ws.Cells.Font
           .Name = "Meiryo UI"
    End With
' カーソルをA1に移動
    ws.Select
    Range("A1").Select
' 表示位置を左上端に移動
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1
' 表示倍率を１００％に戻す
    ActiveWindow.Zoom = 100
End If
Next ws

' １枚目のシートに移動
Sheets(1).Select
'画面更新を再開させておく
Application.ScreenUpdating = True
' メッセージを表示
MsgBox "処理が完了しました"
'
End Sub

3.Step.0 開発タブの表示

開発タブ（上記画像)が表示されていない場合、下記画像(ファイル→オプション→リボンのユーザー設定)から「開発」にチェックを入れて表示。

4.Step.1 個人用マクロブックの作成

①開発タブ>マクロの記録を押下し、下記ポップアップを表示。

②マクロ名に任意の名前を入れ、「マクロの保存先」を 「個人用マクロブック」 に変更し、OKを押下

5.Step2. コードを入れる

①開発タブ>「Visual Basic」を押下。

②画面左上のプロジェクトにて、「VBAProject(PERSONAL XLSB」を開く(「＋」を押下)

③標準モジュール>Module1をダブルクリックして画面右にコード記入画面をポップアウト

④コード入力画面に 「2.コード部分」（本Qiitaの冒頭）で記載のコードをコピペ

※全選択し、最初に入っているSub~~End Subまで消す形でペースト

⑤記録終了を押下し、終了

6.Step.3 クイックアクセスツールバーに登録

ファイル>オプション>クイックアクセスツールバーを選択。
コマンドの選択のドロップダウンにて、マクロを選び、先ほど作成したマクロを選択して追加→OKで保存

7.Step.4 マクロを実行

実行前のExcel

実行(さっき設定したクイックアクセスツールバーでワンクリックする)

実行後のエクセル

※特に参考とさせていただいた投稿
【Excel】”全シートA1セルに合わせ、倍率100％に戻す”マクロショートカットボタンの作成

8.補足-特定のシートについて処理を行わない方法

RAWデータのシートについてはフォントを変えたくない！といったように、特定シートのみ上記の処理を行わないことも可能です。
上記コードでは、シート保護がされているシートについては処理をスキップしているため、処理を行わないシートを保護し、処理後にシート保護を解除することで対応可能です。

なお、複数シートを一括で選択しシート保護をかけることは通常できないため、下記マクロを利用すると楽です。

Sub 複数シート保護()
'
' 複数シート保護 Macro
'
Dim cnt As Long  ' 選択されているシートの数
  Dim sh_name() As String  ' 選択されているシートのName
  Dim sh As Object  ' WorksheetまたはChart
  Dim i As Long
  cnt = ActiveWindow.SelectedSheets.Count
  ReDim sh_name(1 To cnt)
' 選択されているシートのNameを配列に格納
  i = 1
  For Each sh In ActiveWindow.SelectedSheets
    sh_name(i) = sh.Name
    i = i + 1
  Next
' 選択されているシートを順番に保護
  For i = 1 To cnt
    With Sheets(sh_name(i))
      .Select
      .Protect
    End With
  Next i
' 元々選択されていたシートを選択し直す
  For i = 1 To cnt
    Sheets(sh_name(i)).Select Replace:=False
  Next i
'
End Sub

シート保護を解除する際は、解除対象のシートを選択した状態で

Sub 複数シート保護解除()
'
' 複数シート保護解除 Macro
'
Dim cnt As Long  ' 選択されているシートの数
  Dim sh_name() As String  ' 選択されているシートのName
  Dim sh As Object  ' WorksheetまたはChart
  Dim i As Long
  cnt = ActiveWindow.SelectedSheets.Count
  ReDim sh_name(1 To cnt)
' 選択されているシートのNameを配列に格納
  i = 1
  For Each sh In ActiveWindow.SelectedSheets
    sh_name(i) = sh.Name
    i = i + 1
  Next
' 選択されているシートの保護を順番に解除
  For i = 1 To cnt
    With Sheets(sh_name(i))
      .Select
      .Unprotect
    End With
  Next i
' 元々選択されていたシートを選択し直す
 For i = 1 To cnt
    Sheets(sh_name(i)).Select Replace:=False
  Next i
'
End Sub

9.2024年1月ver.

個人的に使用しているマクロをアップデートしたのでメモ

Sub pivotリスト形式()
'
'
On Error GoTo ERR_HNDL
With ActiveSheet.PivotTables(ActiveCell.PivotTable.Name)
    .RowAxisLayout xlTabularRow
    .RepeatAllLabels xlRepeatLabels
    .ColumnGrand = False
    .RowGrand = False
  End With
  
Dim pv_fld As PivotField
  For Each pv_fld In ActiveSheet.PivotTables(ActiveCell.PivotTable.Name).PivotFields
    pv_fld.Subtotals(1) = True
    pv_fld.Subtotals(1) = False
  Next pv_fld
'
ERR_HNDL:

' メッセージを表示
MsgBox "処理が完了しました"
End Sub

Sub ピボット化()
    Dim table As Range
    Dim matrix As Range
    Dim target As Range
    
    If Selection.Cells.Count > 1 Then
        Set matrix = Selection.Cells
        Set table = Range(matrix.CurrentRegion.Cells(1, 1), matrix.Cells(matrix.Rows.Count, matrix.Columns.Count))
    Else
        Set table = ActiveCell.CurrentRegion
        Set matrix = Range(ActiveCell, table.Cells(table.Rows.Count, table.Columns.Count))
        matrix.Select
    End If
    
    If table.Row = matrix.Row Or table.Column = matrix.Column Then
       Beep
       Exit Sub
    End If
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Set target = ActiveWorkbook.Worksheets.Add.Range("A1")
    matrixToList table, matrix, target
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Sub シート見た目整理()
'
' シート見た目整理 Macro
' シート名記載、A,B列幅調整,グリッド消し、フォント修正
'
Dim result

Dim ws As Worksheet

result = MsgBox("全シート処理しますか？(いいえなら1シートのみ)", vbYesNo)

If result = vbYes Then
    Application.ScreenUpdating = False
    '
    ' シート1つずつ処理
    For Each ws In Worksheets
    ' グリッド線を切る
        ActiveWindow.DisplayGridlines = False
        ' シート名入れる
        ws.Range("A1") = "=RIGHT(CELL(""filename"",A1),LEN(CELL(""filename"",A1))-FIND(""]"",CELL(""filename"",A1)))"
        '  1列目に下線入れる
        ws.Range("A1:EA1").Borders(xlEdgeBottom).LineStyle = xlDouble
        ' A,B列を幅1に
        ws.Range("A:B").ColumnWidth = 1
    ' フォントをMeiryo UIにする
        With ws.Cells.Font
               .Name = "Meiryo UI"
               ' .Name = "Arial"
        End With
    ' A1セルを選択
        ws.Select
        Range("A1").Select
    ' 表示を左上に
        ActiveWindow.ScrollColumn = 1
        ActiveWindow.ScrollRow = 1
    ' ズーム100%に
        ActiveWindow.Zoom = 100
    Next ws
    ' 1シート目選択
    Sheets(1).Select
    ' メッセージを表示
    MsgBox "処理が完了しました"

ElseIf result = vbNo Then

    ' 画面更新OFF
    Application.ScreenUpdating = False
    '
    Set ws = ActiveSheet
    ' グリッド線を切る
    ActiveWindow.DisplayGridlines = False
    ' シート名入れる
    Range("A1") = "=RIGHT(CELL(""filename"",A1),LEN(CELL(""filename"",A1))-FIND(""]"",CELL(""filename"",A1)))"
    '  1列目に下線入れる
    Range("A1:EA1").Borders(xlEdgeBottom).LineStyle = xlDouble
    ' A,B列を幅1に
    Range("A:B").ColumnWidth = 1
    ' フォントをMeiryo UIにする
    With ws.Cells.Font
           .Name = "Meiryo UI"
           ' .Name = "Arial"
    End With
    ' A1セルを選択
    Range("A1").Select
    ' 表示を左上に
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1
    ' ズーム100%に
    ActiveWindow.Zoom = 100
    
    ' メッセージを表示
    MsgBox "処理が完了しました"
End If

'画面更新オン
Application.ScreenUpdating = True

End Sub


Sub シート名シート追加()
  
  Dim A
  'シート数分だけ配列を作成
  ReDim A(1 To Sheets.Count)
  
  'シート一覧を配列に格納
  For i = 1 To Sheets.Count
    A(i) = Sheets(i).Name
  Next
  
  'シートを作成
  Sheets.Add before:=Sheets(1)
  ActiveSheet.Name = "シート一覧" 'シート名を変更
  '追加したシートに、シート一覧を入力
  Range("A1").Resize(UBound(A)) = WorksheetFunction.Transpose(A)
  
End Sub