別々のシートを一つのExcelにまとめる～Excel VBA～

いつもありがとうございます。なかまさです。

以前に、複数のシートを一つずつのExcelブックに分割するという内容の記事を投稿しました。

今回はその逆で、それぞれ別々のExcelに保存されているシートを一つのブックに集約するという内容です。

別々に分けたい時もあれば、一つに集約したい時もあるだろうと思いまして、、、、
何かしら皆様の参考や手助けになっていれば幸いです。

内容

とりあえず、作成したExcelを共有します。

シート統合.xlsm

24.4 KB

ファイルダウンロードについて

ダウンロード

今回は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に作ってもらいました！
もちろん、内容を確認して修正は加えていますが、、、
便利な時代になったものです。笑

最後に

どうだったでしょうか？
個人的には自分の作品の発表会みたいで楽しくやらせてもらってます。笑
その上で、誰かの手助けになっていたり、こういう分野に興味も持つきっかけになっていれば嬉しいです。

今回はここまで！ではまた！