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マクロを書くのはいつになるんでしょう。
(おわり)