複数Excelブックの、特定シート、特定列を全部マージする

複数のExcelブックに登録された申込データから、
メールアドレスだけを抜き出す、
とかいう作業を手でやるのは苦痛。
というわけで作ったマクロ。

Sheet1に、以下の通り対象データリストを格納しておく。

------------+-------+-------+---------+
ディレクトリ名|ブック名|シート名|先頭セル名|
c:\Directory|データ.xlsx|申込|D2|

実行すると、新しいブックを作成する。
対象データリストのシートから、データを抽出して、Sheet2に集約していく。
「先頭セル名」で指定されたセルの列にあるデータが全部マージされる。

データ抽出

Option Explicit

Sub データ抽出()
    Dim bkInput As Workbook
    Set bkInput = ThisWorkbook
    Dim shtInput As Worksheet
    Set shtInput = bkInput.Sheets(1)
    Dim bkOutput As Workbook
    Set bkOutput = Workbooks.Add
    shtInput.Copy Before:=bkOutput.Sheets(1)
    Dim shtOutput As Worksheet
    Set shtOutput = bkOutput.Sheets(1)
    Dim shtOutputData As Worksheet
    Set shtOutputData = bkOutput.Sheets(2)

    Dim sPath As String
    Dim sBook As String
    Dim sSheet As String

    Dim Target As Range
    Set Target = shtOutputData.Cells(1, 1)


    Dim nRow As Integer
    nRow = 2
    Do While shtOutput.Cells(nRow, 1) <> ""
        sPath = shtOutput.Cells(nRow, 1)
        sBook = shtOutput.Cells(nRow, 2)
        sSheet = shtOutput.Cells(nRow, 3)

        Dim bkData As Workbook
        Dim shtData As Worksheet

        Set bkData = Workbooks.Open(Filename:=sPath & "\" & sBook, ReadOnly:=True)
        Set shtData = bkData.Worksheets(sSheet)

        Dim sInputCell As String
        sInputCell = shtOutput.Cells(nRow, 4)


        Dim Source As Range
        Set Source = shtData.Range(sInputCell).Resize(shtData.Range(sInputCell).End(xlDown).Row) ' 行だけ最終行まで持っていく

        Source.Copy Target

        bkData.Close

        Set Target = shtOutputData.Cells(1, 1).End(xlDown).Offset(1, 0) '最終行の一つ下を次のTargetにする

        nRow = nRow + 1
    Loop

End Sub