EXCEL フォルダ内にある複数ブックのシート結合

フォルダ内にある複数のブックからシートを読み取り結合します。

参照設定

• Microsoft Office*.* Object Library
• Microsoft Scripting Runtime

コード

Option Explicit

Const TARGET_SHEET_NAME As String = "結合したいシート名"
Const RESULT_SHEET_NAME As String = "結果出力用の新規シート名"
Const NOT_NULL_COLUMN As Long = 1
Const IS_WINDOW_VISIBLE As Boolean = False

Public Sub CombineFile()

    If existSheet(ThisWorkbook, RESULT_SHEET_NAME) Then
        MsgBox "既に［" & RESULT_SHEET_NAME & "］シートが存在します"
        Exit Sub
    End If

    Dim resultSheet As Worksheet
    Set resultSheet = Worksheets.Add()
    resultSheet.Name = RESULT_SHEET_NAME

    Dim targetFolderPath As String
    Dim fd As FileDialog

    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .InitialFileName = ThisWorkbook.Path & "\"
        If .Show = True Then
            targetFolderPath = .SelectedItems(1) & "\"
        Else
            MsgBox "フォルダが選択されませんでした"
            Exit Sub
        End If
    End With

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim startRow As Long
    Dim lastRow As Long

    Application.ScreenUpdating = False
    startRow = 2

    Dim fso As FileSystemObject
    Dim f As File

    Set fso = New FileSystemObject
    For Each f In fso.GetFolder(targetFolderPath).Files
        If LCase(fso.GetExtensionName(f.Name)) Like "xls*" Then
            Set wb = Workbooks.Open(Filename:=f.Path)
            Windows(wb.Name).Visible = IS_WINDOW_VISIBLE

            If existSheet(wb, TARGET_SHEET_NAME) Then
                Set ws = wb.Worksheets(TARGET_SHEET_NAME)
                With ws
                    If .AutoFilterMode Then
                        If .AutoFilter.FilterMode Then
                            .AutoFilterMode = False
                        End If
                    End If

                    lastRow = GetLastRow(NOT_NULL_COLUMN, ws)

                    If startRow = 2 Then
                        .Range(.Rows(1), .Rows(lastRow)).Cells.Copy
                        With resultSheet
                            .Range(.Rows(startRow - 1), .Rows(startRow + lastRow - 2)).PasteSpecial
                        End With
                    Else
                        .Range(.Rows(2), .Rows(lastRow)).Cells.Copy
                        With resultSheet
                            .Range(.Rows(startRow), .Rows(startRow + lastRow - 2)).PasteSpecial
                        End With
                    End If
                End With

                startRow = startRow + lastRow - 1

                Application.DisplayAlerts = False
                wb.Close
                Application.DisplayAlerts = True
                Set ws = Nothing
                Set wb = Nothing
            End If
        End If
    Next f

    Set fso = Nothing
    resultSheet.Cells(1, 1).Select
    Application.ScreenUpdating = True

End Sub

Private Function existSheet(wb As Workbook, sheetName As String) As Boolean
    Dim ws As Worksheet
    Dim ef As Boolean

    ef = False
    For Each ws In wb.Worksheets
        If ws.Name = sheetName Then
            ef = True
            Exit For
        End If
    Next

    existSheet = ef
End Function

Public Function GetLastRow(Optional ColumnNum As Long = 1, Optional ThisSheet As Worksheet) As Long
    If ThisSheet Is Nothing Then
        Set ThisSheet = ActiveSheet
    End If
    With ThisSheet
        GetLastRow = .Cells(.Rows.CountLarge, ColumnNum).End(xlUp).Row
    End With
End Function

定数

• TARGET_SHEET_NAME：各ブックにある結合したいシート名
• RESULT_SHEET_NAME：結果出力用の新規シート名
• NOT_NULL_COLUMN ： 必ず値が入っている列番号（最終行を判定するために使用）
• IS_WINDOW_VISIBLE ：ループ処理の際、対象ワークブックの表示設定（Trueで表示）