エクセルのシート名を一括取得するVBA

エクセルにあるシート名を取得して一覧表を作成するエクセル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

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

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("シート名一覧").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

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("シート名一覧").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

ActiveSheet.Name = "シート名一覧"

Columns("A:B").Select

Columns("A:B").EntireColumn.AutoFit

Selection.NumberFormatLocal = "@"

End If

End Sub

コードの特徴

「ファイルを開く」ダイアログを表示した後、キャンセルをクリックした場合、
キャンセル処理される様に対応しています。
「エクセルのシート名を一括で置換するエクセルVBA」と連携可能な様にしています。