[VBA]フォルダ内にある全てのブックのシート名を取得する

こんにちは、キャンベルです。
最近は週2-3回のペースでお昼にラーメンを食べています。

さて今回は、指定したフォルダ配下にあるExcelブックのシート名を一気に取得する方法について、ご紹介します。
ご紹介するサンプルでは、再帰的には取得しておりません。
再帰的に取得したい場合は、こちらの記事と合わせてお読みください。

:::[VBA]サブフォルダ含むファイル一覧を再帰的に取得する:::

まずは準備から。一覧を表示するためのシートを用意します

イメージとしては、このような順番で結果が表示されるように作っていきます。

1. A2セルにフォルダパスを記入
2. ボタンクリック
3. 指定したパスの直下のExcelファイルのシート名をずらっと表示

では早速、以下のようなシートを一つ作っておきます。
A2セルをパス入力欄、その横に「シート一覧取得」ボタンを設置、5行目から下を結果表示エリアとします。
ボタンの設定の方法などは今回は触れません。
また、ボタンは最後にマクロを割り当てるので、今は設置のみでOKです。

では早速記述していきましょう！

1. Visual Basicエディタの起動

まずはVBAのエディタを起動します。
ショートカットだと、Alt＋F11キーで起動します。
メニューからだと、[開発]→[Visual Basic]で同じ動作になります。

[開発]メニューが表示されていない方は、まず表示させることから始めてください。
（ここでは触れませんので、分からない方は調べてくださいね）

※メニュー[ツール]→[参照設定]で、「Microsoft Scripting Runtime」にチェックが入っていない場合はチェックしておきましょう。

2. モジュール作成

エディタが起動したら、メニューより[挿入]→[標準モジュール]をクリックします。
すると、左側のプロジェクトエクスプローラに「Module1」というファイルが追加されるので、クリックします。

3. コード記述

白い画面に以下をコピペしてください。
なるべく業務でそのまま使えるよう丁寧に書いたので、少し長めになっています。
必要ない部分はカットしてください。

Option Explicit

Sub getSheetName()
    Dim fileArr() As String: ReDim fileArr(0)
    Dim sheetArr(1000, 1)
    Dim buf As String
    Dim path As String
    Dim i As Long, num As Long
    Dim tmpWb As Object, tmpSh As Object
    Dim rowNum As Long, maxRow As Long
    Dim errChk, Ans, preFileNm

    '結果表示行
    rowNum = 5
   
    'データクリア
    maxRow = Cells(Rows.Count, 1).End(xlUp).Row
    Range(Cells(rowNum, 1), Cells(1000, 2)).ClearContents
    
    'パスの最後に「¥」が付いていたら削除
    path = Trim(Cells(2, 1))
    If Right(path, 1) = "¥" Then
        path = Left(path, Len(path) - 1)
    End If
    
    'ディレクトリ存在チェック
    errChk = Dir(path, vbDirectory)
    If errChk = "" Then
        Ans = MsgBox("パスが見つかりません", vbYesNo, "info")
        If Ans = vbNo Then Exit Sub
    End If

    'ディレクトリ内のファイル名を配列に格納
    buf = Dir(path & "¥*.*")
    i = 0
    Do While buf <> ""
        ReDim Preserve fileArr(i)
        fileArr(i) = buf
        buf = Dir()
        i = i + 1
    Loop
    
    '拡張子「.xls」が含まれるファイルのシート名を取得
    Application.ScreenUpdating = False
    num = 0
    For i = 0 To UBound(fileArr)
        If InStr(fileArr(i), ".xls") > 0 Then
            '自身がいたら処理をスキップ
            If InStr(fileArr(i), ThisWorkbook.Name) = 0 Then
                Set tmpWb = Workbooks.Open(Filename:=path & "¥" & fileArr(i), ReadOnly:=True)
                ActiveWindow.Visible = False
                For Each tmpSh In tmpWb.Sheets
                    sheetArr(num, 0) = fileArr(i)   'ファイル名
                    sheetArr(num, 1) = tmpSh.Name   'シート名
                    num = num + 1
                Next
                tmpWb.Close (False)
            End If
        End If
    Next i
    Application.ScreenUpdating = True

    'シート名一覧の作成
    i = 0
    Do While sheetArr(i, 0) <> ""
        'ファイル名は最初のシートのみ出力
        If preFileNm <> sheetArr(i, 0) Then
            Cells(i + rowNum, 1) = sheetArr(i, 0)
        End If
        Cells(i + rowNum, 2) = sheetArr(i, 1)
        preFileNm = sheetArr(i, 0)
        i = i + 1
    Loop
    
End Sub

ボタンにマクロを割り当てれば完了！

最初に設置した「シート一覧取得」ボタンに作ったマクロを割り当てます。
ボタンを右クリック→[マクロの登録]と押すと、先ほど登録したマクロ名「getSheetName」が出てきますので、選択してください。

A2セルにフォルダパスを入力して、ボタンをクリックしてみてください。

うまく表示されましたか？

まとめ

いかがでしたか？
業務効率化などでお使いいただければ幸いです。

自身のシート名を取得するだけならこれだけなので簡単なのですが、フォルダ内だと色々と手間がかかりますね。

Sub wk()
    Dim tmpSh As Object
    For Each tmpSh In Sheets
        Debug.Print tmpSh.Name
    Next
End Sub

ではまたお会いしましょう。