【ExcelVBA】フォルダ内の全ブックを1シートに結合するマクロ

フォルダ内の全ブックを1シートに結合するマクロを紹介します。

具体的な仕様としては、

アクティブブックと同フォルダのブックのうち同じ拡張子の全ブックを対象
ブック内のすべてのシートを結合する
対象はUsedRangeのうち「見出し行」より下のエリア
全行を選択して実行した場合は選択行を見出し行とする
それ以外の場合はあればフィルター見出し、なければ1行目を見出しとする

という仕様のマクロで、取込完了後に以下のログを表示します。

ファイル取込歴

実行型の便利マクロですので、
Excel起動時に裏で開かれる「個人用マクロブック」などに搭載して使ってください。

ショートカットキーに登録したり、ツールバーやリボンにボタン配置すると便利です。

ソースコード
解説

ソースコード

Option Explicit

Public FSO As New FileSystemObject

' フォルダ内の全ブックの結合マクロ
Sub アクティブブックと同フォルダにあるすべてのファイルを結合する()
    
    ' 取込対象のパラメータを取得
    Dim 取込ブック As Workbook: Set 取込ブック = ActiveWorkbook
    Dim path対象フォルダ As String: path対象フォルダ = 取込ブック.Path
    Dim 取込拡張子 As String: 取込拡張子 = FSO.GetExtensionName(取込ブック.Name)
    
    ' 見出し行の取得（全行選択時はその行、フィルターがあればその見出し、なければ1）
    Dim 見出し行 As Long
    If Selection.Address = Selection.EntireRow.Address Then
        見出し行 = ActiveCell.Row
    ElseIf ActiveSheet.AutoFilterMode = True Then
        見出し行 = ActiveSheet.AutoFilter.Range.Row
    Else
        見出し行 = 1
    End If
    
    ' 結果表示シートの作成
    Dim ws結果表示シート As Worksheet
    Set ws結果表示シート = Workbooks.Add.Worksheets(1)
    With ws結果表示シート
        .Name = "取込ログ"
        .Range("B2").Value = "対象フォルダ": .Range("C2").Value = 取込ブック.Path
        .Range("B4").Value = "ファイル名": .Range("C4").Value = "取込結果"
        .Range("B2,B4,C4").HorizontalAlignment = xlCenter
    End With
    
    ' 取込の開始
    取込ブック.Close False ' 一旦代表ファイルも閉じる
    
    ' ■ フォルダ内ファイルの結合
    Dim ws結合シート As Worksheet
    Set ws結合シート = 指定フォルダ内のすべてのブックを結合する(path対象フォルダ, 見出し行, , 取込拡張子, _
            , ws結果表示シート.Range("B5"), ws結果表示シート.Range("C5"))
    
    ' 結果の表示
    ws結果表示シート.Columns("B").AutoFit
    ws結果表示シート.Columns("C").ColumnWidth = 20
    ws結果表示シート.Range("B4").CurrentRegion.Borders.Weight = xlThin
    If ws結合シート Is Nothing Then
        ws結果表示シート.Activate
        MsgBox "結合対象のファイルがありませんでした。"
    Else
        ws結合シート.Move After:=ws結果表示シート
        ws結果表示シート.Activate
        MsgBox "データの結合を完了しました。"
    End If
    
End Sub

' フォルダ内ファイルの結合
Function 指定フォルダ内のすべてのブックを結合する _
    (Path指定フォルダ As String, R_見出し行 As Long _
    , Optional ByVal ファイルLike条件 As String = "*", Optional 対象拡張子 As String = "xlsx" _
    , Optional ByVal シート名Like条件 As String = "*" _
    , Optional ファイル名出力始点セル As Range, Optional 読込結果出力始点セル As Range) As Worksheet
    
    ' 対象フォルダを取得
    If FSO.FolderExists(Path指定フォルダ) = False Then Exit Function
    Dim 対象フォルダ As Folder
    Set 対象フォルダ = FSO.GetFolder(Path指定フォルダ)
    If 対象フォルダ.Files.Count = 0 Then Exit Function
        
    ' 出力するシートは第1ブックの第1シートを利用
    Dim ws出力シート As Worksheet
    
    ' Like条件テキストを生成
    ファイルLike条件 = ファイルLike条件 & "." & 対象拡張子

    ' ファイルの走査ログを出力する各セルをSet
    Dim ファイル名出力セル As Range: Set ファイル名出力セル = ファイル名出力始点セル
    Dim 読込結果出力セル As Range: Set 読込結果出力セル = 読込結果出力始点セル

    ' 指定フォルダ内のすべてのファイルを走査
    Dim 読取結果テキスト As String
    Dim ファイル As File
    For Each ファイル In 対象フォルダ.Files
        読取結果テキスト = ""
        
        ' 条件を満たすファイルを処理
        If ファイル.Name Like ファイルLike条件 Then
            Call 対象ブック内のすべてのシートを取り込む(ファイル.Path, ws出力シート _
                , R_見出し行, シート名Like条件, 読取結果テキスト)
        Else
            読取結果テキスト = "ファイル名条件に合致せず"
        End If
        
        ' 読取ログの出力
        If Not ファイル名出力セル Is Nothing Then
            ファイル名出力セル.Value = ファイル.Name
            Set ファイル名出力セル = ファイル名出力セル.Offset(1)
        End If
        If Not 読込結果出力セル Is Nothing Then
            読込結果出力セル.Value = 読取結果テキスト
            Set 読込結果出力セル = 読込結果出力セル.Offset(1)
        End If

    Next ' 指定フォルダ内のすべてのファイルを走査
    
    Set 指定フォルダ内のすべてのブックを結合する = ws出力シート

End Function

' ブックごとの取込処理
Private Sub 対象ブック内のすべてのシートを取り込む(ファイルパス As String, ws出力シート As Worksheet _
    , R_見出し行 As Long, シート名Like条件 As String, ByRef 読取結果テキスト As String)

    ' ファイルを開く
    Dim wb読取ブック As Workbook: Set wb読取ブック = Nothing
    On Error Resume Next
    Set wb読取ブック = Workbooks.Open(ファイルパス)
    On Error GoTo 0

    If wb読取ブック Is Nothing Then
        読取結果テキスト = "ブックがエラーで開けませんでした。"
        Exit Sub
    End If
    
    ' 開いたブック内の条件合致シートをループ
    Dim cnt読取シート数 As Long: cnt読取シート数 = 0
    Dim ws読取シート As Worksheet
    For Each ws読取シート In wb読取ブック.Worksheets
        If ws読取シート.Name Like シート名Like条件 Then
    
            ' 最初に読み取ったシートをコピーして出力シートとして使う
            If ws出力シート Is Nothing Then
                ws読取シート.Copy
                Set ws出力シート = ActiveSheet
                cnt読取シート数 = cnt読取シート数 + 1
            
            Else
                
                ' UsedRangeのうち見出し行より下を取得
                Dim コピーエリア As Range
                Set コピーエリア = GetUsedRange指定行以下(ws読取シート, R_見出し行 + 1)
                
                ' コピーを実行
                If Not コピーエリア Is Nothing Then
                    コピーエリア.Copy ws出力シート.Cells(Get最終行(ws出力シート) + 1, コピーエリア.Column)
                    cnt読取シート数 = cnt読取シート数 + 1
                End If
            
            End If
    
        End If
    Next ' 開いたブック内の条件合致シートをループ
        
    読取結果テキスト = cnt読取シート数 & "枚のシートを取込"
    wb読取ブック.Close False
            
End Sub

' UsedRangeから上部を切り取り
Function GetUsedRange指定行以下(対象シート As Worksheet, 指定行 As Long) As Range
    With 対象シート
        Set GetUsedRange指定行以下 = Intersect(.UsedRange, .Rows(指定行).Resize(.UsedRange.Rows.Count))
    End With
End Function

' 最終行の取得
Function Get最終行(指定シート As Worksheet) As Long
    Get最終行 = 指定シート.UsedRange.Rows.Count + 指定シート.UsedRange.Row - 1
End Function

解説

メインロジックはFileSystemObjectを用いた基本的なファイル走査コードです。

FileSystemObjectによるファイル走査についてはこちらの記事をご覧ください。
www.limecode.jp

本マクロは実行型の便利マクロですが、その内部で汎用関数を動かしています。

汎用関数の引数は以下の通りとなっており、

' フォルダ内ファイルの結合
Function 指定フォルダ内のすべてのブックを結合する _
    (Path指定フォルダ As String, R_見出し行 As Long _
    , Optional ByVal ファイルLike条件 As String = "*", Optional 対象拡張子 As String = "xlsx" _
    , Optional ByVal シート名Like条件 As String = "*" _
    , Optional ファイル名出力始点セル As Range, Optional 読込結果出力始点セル As Range) As Worksheet