データ集計コード

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