ふぅ 参考までに

このぐらいのことしかやっていない。

Sub 収集()

Dim fso As FileSystemObject

Dim MaxRow As Long

Set fso = New FileSystemObject

Dim pass As String

pass = ThisWorkbook.Path & "\テスト"

Dim month As Date, department As String, fullname As String

Dim i As Long, j As Long

MaxRow = Cells(Rows.Count, 1).End(xlUp).Row

j = MaxRow + 1

Dim f As File

For Each f In fso.GetFolder(pass).Files

    With Workbooks.Open(f)

        With .Worksheets(1)

            i = 18

            Do While .Cells(i, 1).Value <> ""

                Sheet1.Cells(j, 1).Value = .Cells(i, 1).Value

                Sheet1.Cells(j, 2).Value = .Cells(i, 2).Value

                Sheet1.Cells(j, 3).Value = .Cells(i, 3).Value

                Sheet1.Cells(j, 4).Value = .Cells(i, 4).Value

                Sheet1.Cells(j, 5).Value = .Cells(i, 5).Value

                Sheet1.Cells(j, 6).Value = .Cells(i, 6).Value

                i = i + 1

                j = j + 1

            Loop

        End With

        .Close

    End With

Next f

End Sub