エクセル マクロ 特定のフォルダ内 ファイルコピー

質問

エクセルのセルに入力されたフォルダを参照して、
ＣＳＶファイルを　シート１・２・３・４に１度にコピーしたいのですが
例えば

Ｃ\ドキュメント￥フォルダＡ
|-フォルダB
|-フォルダＣ
　　　　　　　　　　　　　　　 |-フォルダＤ
　　　　　　　　　　　　　　　 |-フォルダＥ
　　　　　　　　　　　　　　　　　　　　　　 |-フォルダ１
　　　　　　　　　　　　　　　　　　　　　　　　　　　 |-ＣＳＶファイルＡ　
　　　　　　　　　　　　　　　　　　　　　　 |-フォルダ２
　　　　　　　　　　　　　　　　　　　　　　　　　　　 |-ＣＳＶファイルＢ　　
　　　　　　　　　　　　　　　　　　　　　　 |-フォルダ３
　　　　　　　　　　　　　　　　　　　　　　　　　　　 |-ＣＳＶファイルＣ　
　　　　　　　　　　　　　　　　　　　　　　 |-フォルダ４　
　　　　　　　　　　　　　　　　　　　　　　　　　　　 |-ＣＳＶファイルＤ
上記のアドレスで
シート１のA1セルに　フォルダＥを入力し　
シート２に　ＣＳＶファイルＡ
シート３に　ＣＳＶファイルＢ
シート４に　ＣＳＶファイルＣ
シート５に　ＣＳＶファイルＤ
それぞれすべての内容を貼り付けたいのですが
何分初心者なもので
ご指導いただければと思います。　
ちなみに　A1セルの入力は変わるため各シートは１度削除した上で再度貼り付けを行いたいです。

回答No.1

K Kazz（@JazzCorp）

ワシならこうやる。

'データと同じフォルダにマクロブックを入れる、または、マクロブックと同じフォルダにデータを入れる、結果はどちらでも同じ

Const xExtention = ".csv"
Sub AllTogetherCSV2Sheets()
'Dim xFile As New Scripting.FileSystemObject
Dim xFile As Object
Dim kk As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Worksheets(1).Name = "チェックリスト"
Worksheets(1).UsedRange.Delete
For kk = Worksheets.Count To 2 Step -1
Worksheets(kk).Delete
Next kk
With CreateObject("Scripting.FileSystemObject")
For Each xFile In .getFolder(ThisWorkbook.Path).Files
If InStr(xFile.Name, xExtention) > 0 Then
AllTogetherNow xFile
End If
Next
End With
End Sub
'-------------------------------------------
Sub AllTogetherNow(xFile As Object)
With Workbooks.Open(xFile.Path)
.Worksheets(1).Copy after:=ThisWorkbook.Worksheets(1)
ThisWorkbook.Worksheets(2).Name = Replace(xFile.Name, xExtention, Empty)
.Close
End With
With ThisWorkbook.Worksheets(1)
.Rows(1).Insert Shift:=xlDown
.Hyperlinks.Add _
Anchor:=.Range("A1"), Address:=Empty, _
SubAddress:="'" & Replace(xFile.Name, xExtention, Empty) & "'!$A$1", _
TextToDisplay:=xFile.Name
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub'データと同じフォルダにマクロブックを入れる、または、マクロブックと同じフォルダにデータを入れる、結果はどちらでも同じ

Const xExtention = ".csv"
Sub AllTogetherCSV2Sheets()
'Dim xFile As New Scripting.FileSystemObject
Dim xFile As Object
Dim kk As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Worksheets(1).Name = "チェックリスト"
Worksheets(1).UsedRange.Delete
For kk = Worksheets.Count To 2 Step -1
Worksheets(kk).Delete
Next kk
With CreateObject("Scripting.FileSystemObject")
For Each xFile In .getFolder(ThisWorkbook.Path).Files
If InStr(xFile.Name, xExtention) > 0 Then
AllTogetherNow xFile
End If
Next
End With
End Sub
'-------------------------------------------
Sub AllTogetherNow(xFile As Object)
With Workbooks.Open(xFile.Path)
.Worksheets(1).Copy after:=ThisWorkbook.Worksheets(1)
ThisWorkbook.Worksheets(2).Name = Replace(xFile.Name, xExtention, Empty)
.Close
End With
With ThisWorkbook.Worksheets(1)
.Rows(1).Insert Shift:=xlDown
.Hyperlinks.Add _
Anchor:=.Range("A1"), Address:=Empty, _
SubAddress:="'" & Replace(xFile.Name, xExtention, Empty) & "'!$A$1", _
TextToDisplay:=xFile.Name
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

お礼

回答ありがとうございました。