エクセルマクロをすこし 2018年8月13日 データ収集編

ちょっと解決まで時間がかかったけれど、現状実現したいことある程度できたのでよしとします。
それにしても転んで倒れて手が痛い。。。。

Sub 違うワークブック定型帳票データ複数行収集()
Dim fso As FileSystemObject
Dim MaxRow As Long
Set fso = New FileSystemObject
Dim pass As String
pass = ThisWorkbook.Path & "\zzzz"
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