Photo by
y_kayon
別々のシートを一つのExcelにまとめる～Excel VBA～
いつもありがとうございます。なかまさです。
以前に、複数のシートを一つずつのExcelブックに分割するという内容の記事を投稿しました。
今回はその逆で、それぞれ別々のExcelに保存されているシートを一つのブックに集約するという内容です。
別々に分けたい時もあれば、一つに集約したい時もあるだろうと思いまして、、、、
何かしら皆様の参考や手助けになっていれば幸いです。
内容
とりあえず、作成したExcelを共有します。
今回は2手順踏む形で作成してみました！
手順Ⅰ（シート名集約ボタンを押す！）
対象となるExcelをファイルダイアログから選択する。
※ctrlを押しながらで複数選択できます。
シート「対象」に選択したExcel内のシートの一覧が表示されます。
対象bit欄を1にしたシートを集約の対象とします。
また「集約後シート名」という部分を変更することで、集約後のシート名を指定することが出来ます。
手順Ⅱ（シート結合ボタンを押す！）
手順Ⅰの設定後に、実行ボタンをクリックします。
新規のブックに、選択したシートが集約されます。
※集約後のシート名には連番が付きます。
どうですか？使ってもらえそうですか？笑
プログラム内容
シート名を取得するプログラム
Sub GatherSheetNames()
Dim wsResult As Worksheet
Dim wb As Workbook
Dim wbDialog As FileDialog
Dim filePath As Variant
Dim i As Integer
Dim rowCounter As Integer
' 1. 新しいシートを作成して、結果を表示する
Set wsResult = ThisWorkbook.Sheets("集約シート")
wsResult.Cells.Clear
' ヘッダーを設定する
wsResult.Cells(1, 1).Value = "ブックパス"
wsResult.Cells(1, 2).Value = "シート名"
wsResult.Cells(1, 3).Value = "集約後シート名"
wsResult.Cells(1, 4).Value = "印刷bit"
' ヘッダーにスタイルを追加（オプション）
With wsResult.Range("A1:D1").Font
.Bold = True
.Color = RGB(255, 255, 255) ' 白色
End With
With wsResult.Range("A1:D1").Interior
.Color = RGB(0, 0, 0) ' 黒色
End With
' 2. ファイルダイアログを表示して、ユーザーが選択したファイルを取得する
Set wbDialog = Application.FileDialog(msoFileDialogFilePicker)
wbDialog.AllowMultiSelect = True
wbDialog.Title = "シート名を取得したいExcelファイルを選択してください"
wbDialog.Filters.Clear
wbDialog.Filters.Add "Excel ブック", "*.xls*"
' ダイアログを表示し、選択されたファイルを処理する
If wbDialog.Show = -1 Then
rowCounter = 2
For i = 1 To wbDialog.SelectedItems.Count
filePath = wbDialog.SelectedItems(i)
Set wb = Workbooks.Open(filePath, ReadOnly:=True)
' 各シートの名前を取得して結果シートに書き込む
Dim ws As Worksheet
For Each ws In wb.Worksheets
wsResult.Cells(rowCounter, 1).Value = wb.FullName
wsResult.Cells(rowCounter, 2).Value = ws.Name
wsResult.Cells(rowCounter, 3).Value = ws.Name
wsResult.Cells(rowCounter, 4).Value = 0
rowCounter = rowCounter + 1
Next ws
wb.Close SaveChanges:=False
Next i
End If
' ダイアログを解放する
Set wbDialog = Nothing
' メッセージを表示して処理完了を知らせる
MsgBox "シート名の取得が完了しました。", vbInformation
End Subシートを結合するプログラム
Sub ConsolidateSheets()
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wbNew As Workbook
Dim wsNew As Worksheet
Dim wbOriginal As Workbook
Dim wsOriginal As Worksheet
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim newSheetName As String
Dim sheetNameCounter As Integer
Dim nameExists As Boolean
' 集約シートを含むシートを設定
Set wsSource = ThisWorkbook.Sheets("集約シート")
' 新しいブックを作成
Set wbNew = Workbooks.Add
' 集約シートの最終行を取得
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
'シートに振る連番の初期化
sheetNameCounter = 0
For i = 2 To lastRow ' ヘッダーが1行目にあるため、2行目から開始
If wsSource.Cells(i, "D").Value = 1 Then ' 印刷bitが1の行のみ処理
' 元のブックを開く
Set wbOriginal = Workbooks.Open(wsSource.Cells(i, "A").Value)
' 元のシートをコピー
Set wsOriginal = wbOriginal.Sheets(wsSource.Cells(i, "B").Value)
wsOriginal.Copy After:=wbNew.Sheets(wbNew.Sheets.Count)
' コピー後のシートを新しいブックで設定
Set wsNew = wbNew.Sheets(wbNew.Sheets.Count)
' 新しいシート名を設定
newSheetName = wsSource.Cells(i, "C").Value
' シート名に連番を付ける
sheetNameCounter = sheetNameCounter + 1
newSheetName = wsSource.Cells(i, "C").Value & "_" & sheetNameCounter
' シート名を変更
wsNew.Name = newSheetName
' 元のブックを保存せずに閉じる
wbOriginal.Close SaveChanges:=False
End If
Next i
Application.DisplayAlerts = False
If wbNew.Sheets.Count > 1 Then
wbNew.Sheets(1).Delete
End If
Application.DisplayAlerts = True
MsgBox "シートの集約が完了しました。"
End Subプログラムの大枠はchat-GPTに作ってもらいました！
もちろん、内容を確認して修正は加えていますが、、、
便利な時代になったものです。笑
最後に
どうだったでしょうか？
個人的には自分の作品の発表会みたいで楽しくやらせてもらってます。笑
その上で、誰かの手助けになっていたり、こういう分野に興味も持つきっかけになっていれば嬉しいです。
今回はここまで！ではまた！