【ExcelVBA】地味に便利なシート操作マクロ

標準のショートカットだけでは足りない

Excelでシート間やセルの移動には便利なショートカットキーがあります。
Ctrl＋HomeとかCtrl＋PageDownとか、頻繁に使いますよね。
だけど標準のショートカットキーには、先頭・末尾のシートに移動とか、全部のシートのアクティブセルをA1にするとか、そういうのはない。かゆいところに手が届かない！
そんなわけで、足りない機能は自作のアドインを作ってショートカットキーを設定しています。

今回は主に1機能で1記事書くのはちょっと…という極簡単なマクロを公開します。
大したものじゃないけど、慣れちゃうとこれらを含むアドインなしでExcel使うの不便に感じます…

アドイン自体のざっくりした説明とか作り方はこちら。
【Excel】シート名を部分一致で検索するアドインを作る

あとこんな機能も我ながらヘビーユース。
【Excel】行・列番号またはセルアドレスを指定してアクティブセルを移動する

※1：基本的に自分用として何か起きたら都度修正で使っています。そのため入力チェックとか例外処理は、全般的に甘めです。
※2：Excel2013で動作確認しています。多分2002以降なら動くんじゃないかとは思うけど、もしかしたら古いバージョンだとなんかのプロパティとかで引っかかるかも。

更新履歴
2019/06/11：「ブック内のシート一覧を作成する」を追加

先頭のシートに移動

Private Sub MoveTopSheet()
    Sheets(1).Activate
End Sub

末尾のシートに移動

Private Sub MoveEndSheet()
    Sheets(Sheets.count).Activate
End Sub

選択したシートを削除

確認ダイアログを表示しないで即時削除します。
複数のシートを選択してから実行すると一発で全部削除できます。

' シート削除
Private Sub DeleteSheet()
    With Application
        .ScreenUpdating = False
        If Sheets.Count = 1 Or Sheets.Count = ActiveWindow.SelectedSheets.Count Then
            MsgBox "全てのシートを削除することはできません。", vbCritical
            .ScreenUpdating = True
            Exit Sub
        End If
On Error GoTo ERR_CATCH
        .DisplayAlerts = False
        ActiveWindow.SelectedSheets.Delete
ERR_CATCH:
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub

アクティブシート名変更

これ、別にVBA書かなくても標準でショートカットキーあります。Alt＋O＋H＋Rです。
でもAltでアクセスキーを使って順番に押していくタイプのショートカットキーは、ぶっちゃけ覚えられない…ので、大体アドインにマクロ書いて、適当なショートカットキーを設定しています…
あとシート名のタブを直接編集なのもシート名変更モード？になっているかどうかがわかりづらい。…気がする。
文字数とブック内の既存シート名との競合はチェックしますが、/なんかの使用できない文字のチェックはしていません。必要な場合は組み込んでどうぞ。

便利なコードを公開していらっしゃる方がいました。
Excel のシート名に使えない文字について再考2017

ちなみに空欄または変更前のシート名を変更せずにそのままで「OK」ボタンを押すと、何もしないで終了します。

Private Sub RenameSheet()
    Application.ScreenUpdating = False
    Dim aftName As String: aftName = InputBox("変更後のシート名を入力してください。", "シート名変更", ActiveSheet.name)
    If Len(aftName) = 0 Or aftName = ActiveSheet.name Then
        Exit Sub
    End If
    Dim sht As Worksheet: For Each sht In ActiveWorkbook.Sheets
        If aftName = sht.name Then
            MsgBox "同じ名前のシートが既に存在します。", vbCritical
            Exit Sub
        End If
    Next
    If Len(aftName) > 31 Then
        MsgBox "変更後のシート名が長すぎます。", vbCritical
        Exit Sub
    End If
    ActiveSheet.name = aftName
    Application.ScreenUpdating = True
End Sub

名前をつけてシートコピー

シート名のタブを右クリックしたりドラッグしたりでもコピーはできますが、シート名は元のシート名に(2)がつくだけで指定できないじゃないですか。
最初から名前を付けさせろよ！って思って作った機能です。
シート名変更と同様に文字数とブック内の既存シート名との競合はチェックしますが、使用できない文字のチェックはしていません。

コピー後のシート名を指定するダイアログには、デフォルトでアクティブシート名が設定されます。
変更しないで「OK」を押すと、コピー先のシート名は、アクティブシート名の末尾に「 (2)」を付与したものになります。
ただし、元のシート名が28文字以上の場合、末尾に「 (2)」を付与すると上限の31文字を越えちゃうので、エラーとして処理終了します。
その場合の対処はnewName = activeName & " (2)"の行を以下みたいな感じにすると回避できます。

newName = IIf(Len(activeName) > 27, Left(activeName, 25) & "...", activeName & " ") & "(2)"

これは28文字以上なら「元シート名の左から25文字目まで＋「...(2)」」、それ以外なら「元シート名＋「 (2)」」にするようにした処理です。この辺は好みで変えてください。

Private Sub CopySheet()
    Application.ScreenUpdating = False
    Dim activeName As String: activeName = ActiveSheet.name
    Dim newName As String: newName = InputBox("コピー先のシート名を入力してください。", "シート名", ActiveSheet.name)
    If Len(newName) = 0 Then
        Exit Sub
    End If
    If newName = activeName  Then
        newName = activeName & " (2)"
    End If
    Dim sht As Worksheet: For Each sht In ActiveWorkbook.Sheets
        If newName = sht.name Then
            MsgBox "同じ名前のシートが既に存在します。", vbCritical
            Exit Sub
        End If
    Next
    If Len(newName) > 31 Then
        MsgBox "コピー先のシート名が長すぎます。", vbCritical
        Exit Sub
    End If
    Sheets(activeName).Copy After:=Worksheets(activeName)
    ActiveSheet.name = newName
    Application.ScreenUpdating = True
End Sub

シートの初期化

シート名はそのままで、内容や書式を全クリアします。

Private Sub InitSheet()
    Application.ScreenUpdating = False
    With Cells
        Call .Clear
        Call .Delete Shift:=xlUp
    End With
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub

印刷プレビュー切り替え

2007からでしたっけ？印刷プレビュー画面が変わったの。
2002とか2003使ってた時に書いたコードなんですけど、左側にメニューが出ない旧版の印刷プレビュー画面を表示します。こっちのが好き。

Private Sub PreviewPrint()
    ActiveWindow.SelectedSheets.printPreview
End Sub

改ページビュー切り替え

表示倍率そのままで標準ビューと改ページプレビューを切り替えます。
複数シートを選択した場合、倍率はアクティブシートの倍率で統一されます。
地味に使い勝手がいい。

Private Sub exchangeView()
    Application.ScreenUpdating = False
    With ActiveWindow
        Dim zoom As Integer: zoom = .zoom
        If .View = xlNormalView Then
            .View = xlPageBreakPreview
        Else
            .View = xlNormalView
        End If
        .zoom = zoom
    End With
    Application.ScreenUpdating = True
End Sub

列幅と高さの自動設定

これもアクセスキーを使った幅と高さをそれぞれ自動調整するショートカットキーがあるのですが、案の定覚えられないのと幅と高さまとめて設定するのがなかったので作りました。
シート全体に対して処理します。選択範囲だけを対象とするわけではありません。

Private Sub FitSheet()
    Application.ScreenUpdating = False
    With Cells
        Call .EntireColumn.AutoFit
        Call .EntireRow.AutoFit
    End With
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub

ブック内のシート全てのカーソルと表示領域をA1に合わせる

Private Sub setHomePosition()
    Application.ScreenUpdating = False
    With ActiveWindow
        Dim sht As Worksheet: For Each sht In ActiveWorkbook.Sheets
            With sht
                Dim isVisible As Boolean: isVisible = .Visible
                .Visible = True
                Call .Activate
                Call .Range("A1").Select
            End With
            .scrollRow = 1
            .ScrollColumn = 1
            sht.Visible = isVisible
        Next
    End With
    Call ActiveWorkbook.Sheets(1).Select
    Application.ScreenUpdating = True
End Sub

ブック内のシート一覧を作成する

ブックの先頭にシートを追加し、各シートのA1セルへのリンクを一覧で作成します。
シート名が「シート一覧」であるシートが既にブック内に存在する場合、エラーで落ちます。
気になる方はエラーチェックなり作成するシート名を変更する処理を追加してください。
B列のシート概要欄がいらなければ、Range("B1").value = "シート概要"の削除とSet header = Range("A1:B1")の範囲をA1に変更してください。
この機能は大量のシートを含むテーブル定義書のブックなんかで使うことが多く、大体B列にはINDIRECT関数を使って各シートから引っ張ってきた説明文なんかを表示しています。

作成イメージ

Sub createSheetList()
    Application.ScreenUpdating = False
    With ActiveWorkbook
        Dim shtList As Variant: ReDim shtList(1 To .Sheets.Count, 0)
        Dim i As Long: For i = LBound(shtList, 1) To UBound(shtList, 1)
            shtList(i, 0) = Replace(HYPERLINK_TMP_STR, "@", .Sheets(i).name)
        Next
        Dim newSheet As Worksheet: Set newSheet = .Sheets.Add(Before:=.Sheets(1), Type:=xlWorksheet)
    End With

    With newSheet
        .name = "シート一覧"
        .Range("A1").value2 = "シート名"
        .Range("B1").value2 = "シート概要"
        .Range("A2").Resize(UBound(shtList), 1).formula = shtList

        Dim header As Range: Set header = .Range("A1:B1")
        With header
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            With .Interior
                .pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ColorIndex = 15
            End With
            Call .EntireColumn.AutoFit
        End With

        With .Range(header, header.End(xlDown)).Borders
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .Weight = xlThin
        End With

        Call .Range("A2").Select
    End With

    ActiveWindow.FreezePanes = True
    Application.ScreenUpdating = True
End Sub