ExcelVBAで同じ名前のシートを1つのファイルにまとめるマクロ

まただいぶ間が空いてしまいました。

あいかわらずExcelから離れられない環境にいます。
今回は、複数のExcelブックから同じ名前のシートを集めて保存するVBAマクロを書きました。
VBAマクロを書くのは久しぶりです。

前提

動作はOffice 2013で確認しています。比較的新しいバージョンのExcelを使えば大丈夫だと思いますが、どのくらい古いバージョンまで使えるかは確認していません。

拡張子*.xlsxだけを対象とします。

制限事項

このマクロでは、ファイル自体を探す処理は含まれません。
他のなんらかの方法で、対象ファイルを1ディレクトリーにまとめておく必要があります。

ディレクトリーや保存先などのパラメーターを定数にしています。
フォームで入力できるようにするか、パラメーターを書くシートを作ってそこから読むようにすると便利ですが、今回は省略します。

サンプルデータ

ディレクトリー構成は下記のようにします。

シート集めるマクロ.xlsm
books/
 ├─ 仕様書-××一覧画面.xlsx
 ├─ 仕様書-▲▲登録画面.xlsx
 └─ 仕様書-○○変更画面.xlsx

各ブックには、「項目定義」シートが含まれています。

マクロ作成

新規ブックをExcelマクロ有効形式(*.xlsm)のブックで保存します。
例えば、シートを集めるマクロ.xlsmのようにします。

Alt+F11を入力して、VBAエディターを開きます。

プロジェクトペインのThisWorkbookかSheet1をダブルクリックして、コードペインを開きます。

コードを入力したら、ブックを保存しておきます。

コード

冒頭の定数をお好みの値に変更してください。
定数以外にも、「ブック名からシート名を作る」関数のところは、ファイル名の体系にしたがって変更する必要があります。

Const RESULT_FILE = ".\result.xlsx"
Const TARGET_DIR = ".\books\"
Const TARGET_FILE_FILTER = "仕様書*.xlsx"
Const TARGET_SHEET_NAME = "項目定義"

Sub シートを1つのブックに集めて保存()

    Dim fileName As String
    Dim sheetName As String
    Dim wb As Workbook
    Dim indexSheet, targetSheet As Worksheet

    Application.ScreenUpdating = False ' バックグラウンド処理

    Set wb = Workbooks.Add ' 新規ブック

    ' 初期シートを目次とする
    Set indexSheet = wb.ActiveSheet
    With indexSheet
        .Name = "目次"
        .Range("A1").Value = "目次"
        .Range("A2").Value = "シート名"
        .Range("B2").Value = "ファイル名"
    End With
    ActiveCell.Offset(2, 0).Activate

    ' 各ファイルの処理
    fileName = Dir(TARGET_DIR & TARGET_FILE_FILTER)
    Do While Not fileName = ""

        sheetName = ブック名からシート名を作る(fileName)
        If sheetName = fileName Then
            ' シート名を作るのに失敗したので中断
            MsgBox "シート名の変換に失敗しました。マクロを中断します。ブック名＝" & fileName
            End
        End If

        ' 目次にファイル名とシート名を書き込む
        indexSheet.Activate
        ActiveCell.Value = sheetName
        ActiveCell.Offset(0, 1).Value = fileName

        ' 対象ブックを開く
        With Workbooks.Open(fileName:=TARGET_DIR & fileName)

            ' TARGET_SHEET_NAMEが無ければスキップ
            Set targetSheet = Nothing
            On Error Resume Next
            Set targetSheet = .Worksheets(TARGET_SHEET_NAME)
            On Error GoTo 0
            If targetSheet Is Nothing Then
                indexSheet.Activate
                ActiveCell.Offset(0, 2).Value = "エラー：シートが存在しません"
                GoTo SkipCopying
            End If

            ' シートをコピーしてシート名変更
            targetSheet.Copy After:=wb.Worksheets(wb.Sheets.Count)
            wb.ActiveSheet.Name = sheetName

SkipCopying:
            .Saved = True ' 閉じるときのダイアログを無視させる
            .Close

        End With

        indexSheet.Activate
        ActiveCell.Offset(1, 0).Activate ' 目次のカーソルを次の行に移動
        fileName = Dir() ' 次のファイル

    Loop

    ' シートをまとめたファイルを保存して閉じる
    indexSheet.Activate
    wb.SaveAs fileName:=RESULT_FILE
    wb.Close

End Sub

Function ブック名からシート名を作る(fileName As String) As String

    With CreateObject("VBScript.RegExp") ' 毎回作るのは無駄な気がするけど今回は無視
        .Pattern = "仕様書-(.+).xlsx"
        ブック名からシート名を作る = .Replace(fileName, "$1")
    End With

End Function

補足

「ブック名からシート名を作る」関数の結果が元のファイル名と同じだった場合は、処理を中断させるようにしています。

正規表現の箇所について。
VBAで正規表現を扱うのは初めてなので、これが適切なやり方かどうかはあまり自信がないです。
毎回CreateObjectをするのは無駄があるかも知れませんが、そこまでシビアな処理ではないので無視します。
正規表現を多用する場合は、拡張機能の" Microsoft VBScript Regular Expressions"を使ったほうが良いかも知れません。

変数名にキャメルケースを使用していますが、これはVBAの流儀とは合わないかもしれません。
昔はハンガリアン記法を使うのが一般的だったみたいですけど。
余談ですが、ハンガリアン記法（システムハンガリアン）って廃れつつあるみたいですね。

ハンガリアン記法 - Wikipedia
https://ja.wikipedia.org/wiki/%E3%83%8F%E3%83%B3%E3%82%AC%E3%83%AA%E3%82%A2%E3%83%B3%E8%A8%98%E6%B3%95

おわりに

Visual Basicは、日常的に触る言語と違いが大きいので、ちょっと使っていないとすぐに分からなくなってしまいます。
おまけに、今となってはVB.NETとの違いもあってややこしいです。
実は最初に書いたコードはもっと汚かったので、少しでもすっきりするように試行錯誤しました。

次にVBAマクロを書くのはいつになるんでしょう。

（おわり）

argius note

プログラミング関連

ExcelVBAで同じ名前のシートを1つのファイルにまとめるマクロ

前提

制限事項

サンプルデータ

マクロ作成

コード

補足

おわりに