ブックの集計方法について

質問

複数ファイルにある特定のシートのA列に記載がある時だけ、その行のA列からJ列までを、一つのファイルにコピーしたいと思っています。
ネットで調べてみたところ、エクセルで複数ファイルにある特定のシートの
特定した範囲を一つのファイルにコピーするマクロを探すことができました。

複数のシートから特定のシートのA列に文字がある場合は、J列までを一つのファイルの同じシートにコピーするようなことは出来ないでしょうか？
（例えば、各ブックA列に10行ずつ文字がある場合は、このようなとりまとめをできないかと考えています。）
ブック１（シート名：Q2）⇒集計シートのA１：J１０
ブック２（シート名：Q2）⇒集計シートのA１１：J２０
ブック３（シート名：Q2）⇒集計シートのA２１：J３０

Sub ブック集合()
Dim FileName As String
Dim c As Integer
Dim OpenedBook As Workbook
Dim IsBookOpen As Boolean
ChDir "c:/test"
FileName = Dir("*.xls")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
c = 0
Do While FileName <> ""
If FileName <> ThisWorkbook.Name Then
IsBookOpen = False
For Each OpenedBook In Workbooks
If OpenedBook.Name = FileName Then
IsBookOpen = True
Exit For
End If
Next
If IsBookOpen = False Then
Workbooks.Open (FileName)
End If
Workbooks(FileName).Sheets("Q2").Range("A1:J500　").Copy _
ThisWorkbook.Sheets(3).Cells(c * 500 + 1, 1).PasteSpecial(xlPasteValues)
c = c + 1
If IsBookOpen = False Then
Workbooks(FileName).Close
End If
End If
FileName = Dir()
Loop
Application.DisplayAlerts = True

Application.ScreenUpdating = True
End Sub

回答No.1

keithin · ベストアンサー

sub macro1()
　dim myPath as string
　dim myFile as string
　dim mySheet as string

’初期値の設定はキチンと行う
　mypath = "c:\test\"
　mysheet = "Q2"

　on error resume next
’ブックを巡回する
　myfile = dir(mypath & "*.xls*")
　do until myfile = ""

　’開いて調べてコピーする
　　workbooks.open filename:=mypath & myfile
　　with workbooks(myfile).worksheets(mysheet)
　　if application.counta(.range("A:A")) > 0 then
　　　.range("1:1").insert
　　　.range("A1") = "dammy head"
　　　.range("A:J").autofilter field:=1, criteria1:="<>"
　　　.autofilter.range.offset(1).copy _
　　　　destination:=thisworkbook.worksheets(1).range("A65536").end(xlup).offset(1)
　　end if
　　end with
　　workbooks(myfile).close savechanges:=false
　　myfile = dir()
　loop
end sub

みたいな。

お礼

ご回答いただきありがとうございました。
頂いた内容で試行錯誤しておりましたが、なんとか出来そうです。
どうもありがとうございました。
改めて御礼が遅くなりましてすみませんでした。