VBAでご相談です！

質問

Excel2010使用。
VBA初心者です。
VBAでご相談させて下さい。
複数のファイルを１つにまとめる
作業をしたいと思い、ググったところ
あるサイトで下記のコードを見つけました。
ただ、このコードでは、ファイルをダイアログから
選択する形になります。
これを、ファイルを指定した状態で実行させたいと思い、
自分で試してみたのですが、上手くいきませんでした。
同一フォルダ内には４つのファイルがあり、全て同じ様式の
シートが複数あります。ただ、フォルダ名が毎月変更になります。
この同一フォルダ内のデータの中の特定のシートを一つのシートに
まとめたいと考えているのですが、可能でしょうか？
可能であれば、アドバイスいただけるとありがたいです。

Sub sample()
Dim myPath As String
Dim wb_A As Workbook, wb_B As Workbook
Dim i As Long, s As Long
myPath = Application.GetOpenFilename(("Excel ファイル (*.xls), *.xls"), , "データを蓄積するブックを選択して下さい。")
If myPath = "False" Then Exit Sub
Set wb_A = Workbooks.Open(myPath)
myPath = Application.GetOpenFilename(("Excel ファイル (*.xls), *.xls"), , "データを取得するブックを選択して下さい。")
If myPath = "False" Then Exit Sub
Set wb_B = Workbooks.Open(myPath)
With wb_B
For i = 1 To .Worksheets.Count 'wb_Bループ
For s = 1 To wb_A.Worksheets.Count 'wb_Aループ
'同じ名前のシートがあるとき データコピー
If .Worksheets(i).Name = wb_A.Worksheets(s).Name Then
.Worksheets(i).Range("A1").CurrentRegion.Copy _
wb_A.Worksheets(i).Range("A65536").End(xlUp).Offset(1)
Exit For
End If
'同じ名前のシートが無いとき シートコピー
If s = wb_A.Worksheets.Count Then
.Worksheets(i).Copy Before:=wb_A.Sheets(1)
End If
Next s
Next i
wb_B.Close False
MsgBox "完了"
End With
End Sub

※長文、説明下手で申し訳ありませんが
よろしくお願いします。

＜参考URL＞
　　http://www.excel.studio-kazu.jp/kw/20040709212700.html

回答No.1

end-u · ベストアンサー

>これを、ファイルを指定した状態で実行させたいと思い、
『指定した状態』とは？
たとえば下記のマクロを書いてあるBook、
つまりThisWorkbookを開いた状態でマクロを実行する、という解釈で良いでしょうか？

以下、サンプルです。
※集約したい特定のシートのシート名は共通だと解釈してConst sName = "DATA"の箇所で指定するようにしています。
マクロ内容としては
1)GetOpenFilenameダイアログで複数Bookをまとめて選択します。
2)選択したファイルを順次開いて処理後閉じます。
3)ThisWorkbookにシートを追加してそこに集約します。

Sub try()
　　Const sName = "DATA" '特定のシートのシート名に変更必要。
　　Dim dest As Range
　　Dim r　　As Range
　　Dim x, ary, ar

　　On Error GoTo errout
　　'取得するBookをCtrl+クリックでまとめて選択。
　　x = Application.GetOpenFilename("XLfiles,*.xl*", MultiSelect:=True)
　　If VarType(x) = vbBoolean Then MsgBox "cancel": Exit Sub

　　Application.ScreenUpdating = False
　　If IsArray(x) Then
　　　　ary = x
　　Else
　　　　ReDim ary(0)
　　　　ary(0) = x
　　End If

　　'このマクロが書いてあるBookにSheetを追加して集約。 _
　　 あるSheetに変更するなら差替え必要。
　　Set dest = ThisWorkbook.Worksheets.Add.Range("A1")
　　'Set dest = ThisWorkbook.Worksheets("集約").Range("A1")
　　'dest.Worksheet.UsedRange.Clear '"集約"シートの既存クリアが必要な場合。

　　For Each ar In ary
　　　　With Workbooks.Open(ar, ReadOnly:=True)
　　　　　　On Error Resume Next
　　　　　　Set r = .Sheets(sName).UsedRange
　　　　　　On Error GoTo errout
　　　　　　If Not r Is Nothing Then
　　　　　　　　dest.Value = ar
　　　　　　　　Set r = Excel.Range(r.Worksheet.Range("A1"), r.Item(r.Count))
　　　　　　　　r.Copy dest.Offset(, 1)
　　　　　　　　Set dest = dest.Offset(r.Rows.Count)
　　　　　　　　Set r = Nothing
　　　　　　End If
　　　　　　.Close False
　　　　End With
　　Next

errout:
　　Application.ScreenUpdating = True
　　With Err
　　　　If .Number <> 0 Then
　　　　　　MsgBox .Number & "::" & .Description
　　　　End If
　　End With
End Sub

dataシートを列いっぱい使っていたらエラーになります。
その他、同名Bookを既に開いていてOpenをキャンセルするとエラーになります。
そういったエラー対策は無しで、メッセージもExcelに任せてます。
必要であれば工夫してみてください。

お礼

end-u様、ありがとうございます。
教えていただいたコード、早速試して見ました。
説明が下手であった為、残念ながら私の意図する
動作ではありませんでした。ただ、内容を1つずつ
紐解いていくと、すごく勉強になる内容でした。
今回、私がしようとしていることは少し複雑というか
説明が難しくてなかなか伝えきれないもどかしさが
あります。なので、end-u様から教えて頂いた内容を
利用させていただきながら、なんとか自分で解決して
いきたいと思います。ありがとうございました！