フォルダ内の複数ブックを一つのシートにまとめる

エクセルのVBAで特定のフォルダ内にある複数のブックを
一つのシートにまとめるVBAを教えて頂けないでしょうか。
範囲は、B5からS列のデータのある最終行までです。

バージョンはexcel2013です。

質問者からの補足コメント

• 

  ありがとうございます！できました。
  もうひとつわがままなことなのですが、ブックの１枚目のシートのみをコピーすることはできますか？

  No.1の回答に寄せられた補足コメントです。 補足日時：2015/08/05 09:59

No.3 回答者： hallo-2007 回答日時： 2015/08/05 20:32

>ブックの１枚目のシートのみをコピーすることはできますか？

For i = 1 To Worksheets.Count
Sheets(i).Activate
・・・
・・・
Next
で全てのシートを繰り返していますので

Sheets(1).Activate
For k = 1 To Range("A" & Rows.Count).End(xlUp).Row
.Range("A" & j).Value = buf
.Range("B" & j).Value = Sheets(i).Name
.Range("C" & j & ":E" & j).Value = Range("A" & k & ":C" & k).Value
j = j + 1
Next
で十分ではないでしょうか。

No.2 回答者： WindFaller 回答日時： 2015/08/05 18:52

>ブックの１枚目のシートのみをコピーすることはできますか？

以下のように加えると良いと思います。
他のコードに貼り付ける時は、親オブジェクトを考慮してください。

cnt = ThisWorkbook.Worksheets.Count
　　　　　 '＊ブックの一枚目のシートのコピー
　　　　（親オブジェクト).Worksheets(1).Copy After:=ThisWorkbook.Worksheets(cnt)
　　　　　On Error Resume Next
　　　　　ActiveSheet.Name = FName
　　　　　On Error GoTo 0



'//
Sub OpenSheetGetData()
'No. 9036670
　Dim MyPath As String
　Dim FName As String
　Dim i As Long, j As Long, cnt As Long
　Dim sh As Variant
　Dim Lastrow As Long
　Dim acSh As Worksheet
　Set acSh = ActiveSheet
　j = 2
　MyPath = ThisWorkbook.Path & "\"
　FName = Dir(MyPath & "*.xls?", vbNormal)
　Do While FName <> ""
　　If FName <> "." And FName <> ".." Then
　　　If (GetAttr(MyPath & FName) And vbNormal) = vbNormal Then
　　　　With Workbooks.Open(MyPath & FName)
　　　　　For Each sh In .Worksheets
　　　　　　With sh
　　　　　　　Lastrow = .Cells(Rows.Count, "B").End(xlUp).Row
　　　　　　　'リミット（10000行以下のものを対象)
　　　　　　　If Lastrow > 5 And Lastrow < 10000 Then
　　　　　　　　For i = 5 To Lastrow
　　　　　　　　　acSh.Cells(j, 2).Resize(, 18).Value = .Cells(i, 2).Resize(, 18).Value
　　　　　　　　　j = j + 1
　　　　　　　　Next i
　　　　　　　End If
　　　　　　End With
　　　　　Next sh
　　　　　 cnt = ThisWorkbook.Worksheets.Count
　　　　　 '＊ブックの一枚目のシートのコピー
　　　　　.Worksheets(1).Copy After:=ThisWorkbook.Worksheets(cnt)
　　　　　On Error Resume Next
　　　　　ActiveSheet.Name = FName
　　　　　On Error GoTo 0
　　　　　.Close False
　　　　End With
　　　End If
　　End If
　　FName = Dir()
　Loop
End Sub
'///

No.1 回答者： hallo-2007 回答日時： 2015/08/04 20:24

参考になるかと

https://oshiete.goo.ne.jp/qa/9029811.html
で同じような回答をいたしました。
5行目からであれば
For k = 1 To Range("A" & Rows.Count).End(xlUp).Row
を
For k = ５ To Range("A" & Rows.Count).End(xlUp).Row
に

Ｂ列からＳ列なら
.Range("C" & j & ":T" & j).Value = Range("B" & k & ":S" & k).Value
です。
Ａ列には　ファイル名
Ｂ列には　シート名が入ります。
不要であれば
.Range("A" & j).Value = buf
.Range("B" & j).Value = Sheets(i).Name
を削除してください。
このファイルが、その特定のフォルダ内に保存して使用します。