USBのファイルを取り込むマクロについて教えてください。

どなたかよろしくお願いします。

Excel2013でマクロを組んでUSBのデータをDドライブに取り込んでいます。
EドライブのドライブレターがUSBを刺した時にFとかGに書き換わる事が有るため下記のマクロをネットで見つけました。日報DATA（E）がドライブレターです。

Sub USB_drive()
'
' USB_drive Macro
'
Dim fs As Object, dvs As Object, dv As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set dvs = fs.drives
For Each dv In dvs
With dv
If .isready And .drivetype = 1 Then
If .volumename = "日報DATA" Then
MsgBox "USBドライブは " & .driveletter & " です。"

End If
End If
End With
Next
Set fs = Nothing
Set dvs = Nothing

End Sub

上記のようにドライブレターを取得してそれを使って現在動かしているマクロの
Const cnsSOUR = "E:\data\*.csv"
のEの部分を置換して動かすことはできるでしょうか。
E:はUSBドライブでDATAフォルダーのCSVファイルをD:ドライブのDATA2フォルダーに全部コピーしています。

下記が現在使っているマクロです
Sub USB取り込み()
'
Dim rc As Integer
intMsgBox = MsgBox("USBからの取り込みをを実行しますか？", vbOKCancel)
If intMsgBox = vbCancel Then
MsgBox "取り込みをキャンセルしました"
Exit Sub
　　 End If

Const cnsSOUR = "E:\DATA\*.csv" ' 元ファイル(拡張子CSV全て)
Const cnsDEST = "D:\DATA2\" ' 先フォルダ
Dim objFSO As FileSystemObject ' FSO
Set objFSO = New FileSystemObject
' ファイルコピー
objFSO.CopyFile cnsSOUR, cnsDEST, True
　 Set objFSO = Nothing
Application.ScreenUpdating = True '画面更新
MsgBox "ＵＳＢからの取り込みは正常に終了しました"

Sheets("操作").Select
Range("A1").Select

End Sub
他に方法があればそちらでも結構です
よろしくお願いします。

No.1 ベストアンサー 回答者： WindFaller 回答日時： 2015/07/14 13:12

コードをそのまま活かすことにしました。

Const cnsSOUR = "E:\DATA\*.csv" ' 元ファイル(拡張子CSV全て)
これを、やめて、

'//
Dim mySOURCE　As String　　'モジュールレベルの変数にします。

Sub USB_drive()
　'
　' USB_drive Macro
　'
　Dim objFSO As FileSystemObject　'参照設定
　Dim dvs As Object, dv As Object
　Set objFSO = New FileSystemObject
　Set dvs = objFSO.drives
　For Each dv In dvs
　　With dv
　　　If .IsReady And .DriveType = 1 Then
　　　　'If .VolumeName = "日報DATA" Then
　　　　　MsgBox "USBドライブは " & .DriveLetter & " です。"
　　　　　mySOURCE = .DriveLetter　　'←これを加えます。
　　　　'End If
　　　End If
　　End With
　Next
　Set objFSO = Nothing
　Set dvs = Nothing
　Call USB取り込み
End Sub

Sub USB取り込み()　'
　Dim rc As Integer '生きていない変数
　Dim intMsgBox As VbMsgBoxResult
　Dim objFSO As FileSystemObject ' FSO　Windows Script Host Object Model (参照設定なら、上記のコードもそのまま使いましょう)
　
　Const cnsDEST = "D:\DATA2\" ' 先フォルダ　(これはそのまま)
　
　intMsgBox = MsgBox("USBからの取り込みをを実行しますか？", vbOKCancel)
　If intMsgBox = vbCancel Then
　　MsgBox "取り込みをキャンセルしました"
　　Exit Sub
　End If
　
　'このように、取得したドライブ名を以下に当てます。
　mySOURCE = mySOURCE & ":\DATA\*.csv"　' 元ファイル(拡張子CSV全て)
　
　Set objFSO = New FileSystemObject
　' ファイルコピー
　 objFSO.CopyFile mySOURCE, cnsDEST, True

　Application.ScreenUpdating = True '画面更新
　If rc = 0 Then
　　MsgBox "ＵＳＢからの取り込みは正常に終了しました"
　End If
　
　 Sheets("操作").Select
　Range("A1").Select
　Set objFSO = Nothing
End Sub

'///

この回答へのお礼

ありがとうございます。感激です
おかげさまでドライブレターが書き換わっても
取り込む事が出来るようになりました。
参照設定でＵＳＢも見分けられるようになりました。

パソコンのＯＳがWindows8.1に新しくなり書き換わって
エラーが多く出るようになってましたので助かりました。

一日悩んでいたのがウソのようです
回答いただきまして本当にありがとうございました。

お礼日時：2015/07/14 20:51