CSV名と同じシートを選択して取り込む ＶＢＡ

いつもお世話になっております。
複数（４個）のUSBから名前の違う複数のCSVデータを、同一のBookにある、それぞれ準備したCSV名のシートを選択するマクロを組みたいと考えております。

エクセルは２０１０です。
テスト．xlsm に
シート名【Date1】【Date2】【Date3】【Date4】がすでに準備されており、
それぞれのUSBの中のCSVファイルは、Date1～Date4 までの、どれかのファイルが１つずつ入っており読み込みボタンを押して同名のシートへインポートを行い、USBのCSVファイルもすべて削除をしたいと考えております。

シートの有無などをチェックを行いながら、処理出来れば理想的です。
CSVファイル名をシート名に処理するという、他のすばらしいコードを参考してみましたが解読・変更が出来ません。ご教示よろしくお願い致します。

Sub ReadMultiCSVFiles()
' [[ 変数定義 ]]
Dim varFileName As Variant
Dim CSVWorkSheet As Worksheet
Dim NewWorkSheet As Worksheet
Dim SheetName As String

' [[ コピー範囲の変数 ]]
Dim R1 As Integer
Dim R2 As Integer
Dim C1 As Integer
Dim C2 As Integer

' [[ 複数ファイルパス名を取得 ]]
varFileName = Application.GetOpenFilename(FileFilter:="CSVファイル(*.csv),*.csv", _
Title:="CSVファイルの選択", MultiSelect:=True)

' [[ ファイルパス取得できなかったら ]]
If IsArray(varFileName) = False Then
Exit Sub
End If

' [[ ファイルパス取得できたら ]]
For Each Filename In varFileName
' [[ ファイルパスからファイル名を取得 ]]
SheetName = Dir(Filename)
' [[ ファイル名で新しいシート作成 ]]
Set NewWorkSheet = CreateWorkSheet(SheetName)

' [[ CSVファイルを開く ]]
Workbooks.Open Filename:=Filename
Set CSVWorkSheet = ActiveSheet

' [[ 有効セルの範囲取得 ]]
R1 = CSVWorkSheet.UsedRange.Row
C1 = CSVWorkSheet.UsedRange.Column
R2 = CSVWorkSheet.UsedRange.End(xlDown).Row
C2 = CSVWorkSheet.UsedRange.End(xlToRight).Column

' [[ 有効セルの範囲のコピー ]]
CSVWorkSheet.UsedRange.Copy Destination:=NewWorkSheet.Range(NewWorkSheet.Cells(R1, C1), NewWorkSheet.Cells(R2, C2))

' [[ CSVファイルを閉じる(保存無し) ]]
ActiveWorkbook.Close SaveChanges:=False
Next

End Sub

' ワークシート名を指定したワークシートの作成

Function CreateWorkSheet(WorkSheetName As String) As Worksheet

' 変数定義
Dim NewWorkSheet As Worksheet
Dim iCheckSameName As Integer

' ワークシートの作成
' ※一番最後に挿入
Set NewWorkSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))

' 同じ名前ワークシートが無いか確認
iCheckSameName = 0
For Each ws In Sheets
If ws.Name = WorkSheetName Then
MsgBox "ワークシート名：" + WorkSheetName + " この名前は既に使われています。"
iCheckSameName = 1
End If
Next

'同じ名前のワークシートがなければ
If iCheckSameName = 0 Then
NewWorkSheet.Name = WorkSheetName
Set CreateWorkSheet = NewWorkSheet
End If

End Function

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

• 

  ki-aaa さん
  
  早速にありがとうございます。思った通りの動きが出来ました！
  ２点ありまして、
  
  ①取り込んだ csvのシート名が【Date1.csv】に名前がついてしまい、すべて新規のワークシートとして追加されてしまいます。
  ②同名のシートが無ければ処理を抜けて、Mg "シートが見当たりません”と処理を抜けたいのですが、記述はどのようになりますでしょうか？
  
  いろいろと触ってみましたが、よろしくお願い致します。

  No.1の回答に寄せられた補足コメントです。 補足日時：2017/01/23 17:15

• 

  ki-aaa　様、ありがとうございます！思ったとおりとなりました。
  度々申し訳ございません。取り込んだCSVデータを別の名前でデスクトップ￥実績フォルダに保存する処理はどのように記述すればよろしかったでしょうか？バックグランドで処理を走らせたいと考えております。
  Dim Fn, As String, re As Long
  Sheets(Ws).Copy
  Fn = Format(Range("A2"), "yyyy" & "_" & "mm") & "Date"
  ActiveWorkbook.SaveAs Filename:="C:\Desktop\実績フォルダ\" & Fn, FileFormat:=xlCSV, Local:=True
  ActiveWindow.Close
  などど、他の処理で使用しております。
  【Sheets(Ws).Copy】などはあっておりますでしょうか？

    補足日時：2017/01/24 01:38

No.2 回答者： ki-aaa 回答日時： 2017/01/23 19:21

①.csvは消しています。

②そのように変更しました。


Sub ReadMultiCSVFiles()
' [[ 変数定義 ]]
Dim varFileName As Variant
Dim CsvWs As Worksheet
Dim SheetName As String
Dim myFileName
Dim Ws As Worksheet

' [[ 複数ファイルパス名を取得 ]]
varFileName = Application.GetOpenFilename(FileFilter:="CSVファイル(*.csv),*.csv", _
Title:="CSVファイルの選択", MultiSelect:=True)

' [[ ファイルパス取得できなかったら ]]
If IsArray(varFileName) = False Then
Exit Sub
End If

' [[ ファイルパス取得できたら ]]
For Each myFileName In varFileName
' [[ ファイルパスからファイル名を取得 ]]
SheetName = Dir(myFileName)

' 同じ名前ワークシートが無いか確認
Set Ws = Nothing
On Error Resume Next
Set Ws = Worksheets(Left(SheetName, Len(SheetName) - 4))
On Error GoTo 0

If Ws Is Nothing Then
' 無い時の処理
MsgBox "シートが見当たりません"
Exit Sub
Else
' ワークシートのClear
Ws.Cells.ClearContents
End If


' [[ CSVファイルを開く ]]
Workbooks.Open Filename:=myFileName
Set CsvWs = ActiveSheet


' [[ 有効セルの範囲のコピー ]]
CsvWs.UsedRange.Copy Destination:=Ws.Range("A1")

' [[ CSVファイルを閉じる(保存無し) ]]
ActiveWorkbook.Close SaveChanges:=False

' [[ CSVファイルをKill(保存無し) ]]
'Kill (myFileName) ' テストファイルを作り、テストを十分してからコメントマークを消してください。
' 私個人はファイルの消去は自動で行わない方が良いと思います。
Next

End Sub

No.1 回答者： ki-aaa 回答日時： 2017/01/23 12:10

これでどうかな

Sub ReadMultiCSVFiles()
' [[ 変数定義 ]]
Dim varFileName As Variant
Dim CsvWs As Worksheet
Dim NewWs As Worksheet
Dim SheetName As String
Dim myFileName

' [[ コピー範囲の変数 ]]
Dim Row1 As Long
Dim Row2 As Long
Dim Col1 As Long
Dim Col2 As Long

' [[ 複数ファイルパス名を取得 ]]
varFileName = Application.GetOpenFilename(FileFilter:="CSVファイル(*.csv),*.csv", _
Title:="CSVファイルの選択", MultiSelect:=True)

' [[ ファイルパス取得できなかったら ]]
If IsArray(varFileName) = False Then
Exit Sub
End If

' [[ ファイルパス取得できたら ]]
For Each myFileName In varFileName
' [[ ファイルパスからファイル名を取得 ]]
SheetName = Dir(myFileName)
' [[ ファイル名で新しいシート作成 ]]
Set NewWs = CreateWorkSheet(SheetName)

' [[ CSVファイルを開く ]]
Workbooks.Open Filename:=myFileName
Set CsvWs = ActiveSheet

' [[ 有効セルの範囲取得 ]]
Row1 = CsvWs.UsedRange.Row
Col1 = CsvWs.UsedRange.Column
Row2 = CsvWs.UsedRange.End(xlDown).Row
Col2 = CsvWs.UsedRange.End(xlToRight).Column

' [[ 有効セルの範囲のコピー ]]
CsvWs.UsedRange.Copy Destination:=NewWs.Range(NewWs.Cells(Row1, Col1), NewWs.Cells(Row2, Col2))

' [[ CSVファイルを閉じる(保存無し) ]]
ActiveWorkbook.Close SaveChanges:=False

' [[ CSVファイルをKill]]
'Kill (myFileName) ' テストファイルを作り、テストを十分してからコメントマークを消してください。
' 私個人はファイルの消去は自動で行わない方が良いと思います。
Next

End Sub


' ワークシート名を指定したワークシートの作成
Function CreateWorkSheet(WsName As String) As Worksheet
Dim Ws As Worksheet

' 同じ名前ワークシートが有るか確認
On Error Resume Next
Set Ws = Worksheets(WsName)
On Error GoTo 0

If Ws Is Nothing Then
' ワークシートの作成
' ※一番最後に挿入
Set Ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
Ws.Name = WsName
Else
' ワークシートのClear
Ws.Cells.Clear
End If
Set CreateWorkSheet = Ws
End Function


'Kill (myFileName)はコメントになっていますので、自己責任で実行できるようにしてください。