Option Explicit Sub

kousin()

Dim i As Long

Dim j As Long

Dim str As String

Dim strFileName As String

Dim wb As Workbook

Dim ws As Worksheet

Dim wbOwn As Workbook

Application.ScreenUpdating = False

str = ActiveSheet.Range("B3").Value

Set wbOwn = Workbooks("データ一覧")

strFileName = Dir("D:\ｴｸｾﾙ資料\データ共有" & "\*xlsx")

i = 6

Do While strFileName <> ""

Set wb = Workbooks.Open("D:\ｴｸｾﾙ資料\データ共有" & "\" & strFileName)

j = 6

Do Until wb.Worksheets(str).Range("A" & j) = ""

wb.Worksheets(str).Activate

wb.Worksheets(str).Range(Cells(j, 1), Cells(j, 7)).Copy

wbOwn.Activate wbOwn.Worksheets(str).Range(Cells(i, 1), Cells(i, 7)).PasteSpecial

j = j + 1 i = i + 1 Loop

wb.Close savechanges:=False

strFileName = Dir() Loop

Application.ScreenUpdating = True

End Sub

Excel