ブックのシート名を取得して一覧表を作成するエクセルVBA

5072 ワード
VBA マクロ 効率化 自動化 Excel Excel テキストリンク

ブックにあるシート名を取得して一覧表を作成するエクセルVBAをご紹介します。

次のサンプルコードを使うと、


  • 「ファイルを開く」ダイアログを表示。

  • シート名を取得したいエクセルブックを選択。

  • 選択したエクセルブックに、「シート名一覧」シートを追加。

  • エクセルブックに含まれる全シート名を取得、「シート名一覧」にシート名の一覧表を作成する。


という作業を自動化します。

操作方法


1、
下記サンプルコードを含むエクセルファイルを開き→「開発」→「マクロ」の順でクリック。
「Aシート名取得」→「実行」の順でクリック。

2、
ファイルを開くダイアログが表示されるので、シート名を取得したい対象のエクセルブックをクリックして、「開く」をクリック。

3、
マクロが実行されます。
「シート名一覧」を追加、全シート名を取得して、
「シート名一覧」にシート名の一覧表を作成します。

完了です。

サンプルコード


Sub Aファイルを開く()
    Dim OpenFileName As String

OpenFileName = Application.GetOpenFilename("Excelファイル,*.xls*")

If OpenFileName = "False" Then

    MsgBox "キャンセルされました。処理を終了します。"

    End

Else
    Workbooks.Open OpenFileName

End If


End Sub
Sub Aシート名取得()
    Dim sh As Variant, flag As Boolean
    Dim ws As Worksheet
    Dim i As Long
    i = 0

Call Aファイルを開く


'画面更新停止
Application.ScreenUpdating = False

'確認ダイアログ停止
Application.DisplayAlerts = False

For Each sh In Sheets
    If sh.Name = "シート名一覧" Then
        flag = True
        Exit For
    End If
Next sh

If flag = True Then

    Dim rc As Integer

    'メッセージ表示
    rc = MsgBox("シート「シート名一覧」を上書きしますか？" & Chr(13) & "※この処理は戻せません", vbYesNo + vbQuestion, "確認")

    If rc = vbYes Then
        '画面更新停止
        Application.ScreenUpdating = False

        'シート選択
        Worksheets("シート名一覧").Activate

        'シート削除
        ActiveSheet.Delete

        '画面更新停止
        Application.ScreenUpdating = True

        'メッセージ表示
        MsgBox "処理前のシート「シート名一覧」は削除済みです"

        'シート追加
        Worksheets.Add before:=Worksheets(1)

        'シート名変更
        ActiveSheet.Name = "シート名一覧"

        'シート選択
        Worksheets("シート名一覧").Activate

        Worksheets("シート名一覧").Activate
        Worksheets("シート名一覧").Range("A1").Value = "シート名（現在）"
        Worksheets("シート名一覧").Range("B1").Value = "シート名（変更後）"

        For Each ws In Worksheets
            Cells(Selection.row + i, Selection.Column).NumberFormatLocal = "@"
            Cells(Selection.row + i, Selection.Column) = ws.Name
            i = i + 1
        Next

        ActiveSheet.Name = "シート名一覧"
        Columns("A:B").Select
        Columns("A:B").EntireColumn.AutoFit
        Selection.NumberFormatLocal = "@"

    Else

        'メッセージ表示
        MsgBox "キャンセルされました。処理を終了します。"

    End If

Else

    'シート追加
    Worksheets.Add before:=Worksheets(1)

    'シート名変更
    ActiveSheet.Name = "シート名一覧"

    'シート選択
    Worksheets("シート名一覧").Activate

    Worksheets("シート名一覧").Activate
    Worksheets("シート名一覧").Range("A1").Value = "シート名（現在）"
    Worksheets("シート名一覧").Range("B1").Value = "シート名（変更後）"

    For Each ws In Worksheets
        Cells(Selection.row + i, Selection.Column).NumberFormatLocal = "@"
        Cells(Selection.row + i, Selection.Column) = ws.Name
        i = i + 1
    Next

    ActiveSheet.Name = "シート名一覧"
    Columns("A:B").Select
    Columns("A:B").EntireColumn.AutoFit
    Selection.NumberFormatLocal = "@"

End If


End Sub

 

コードの特徴