Enregistrement sur clé usd

Je souhaite utilisé ce code sur une clé usd mais le nom du disque change en fonction de l'ordinateur que j'utilise.

Avez vous un solution pour m'aidé.

Merci d'avance

Sub ColleEtSauve()
'
Dim MaPlage As Range

LaDate = Year(Date) & "-" & Month(Date) & "-" & Day(Date) 'Variable qui prend la date du jour format aaaa-m-j
Set MaPlage = Range("A1:L34") 'Applique la plage voulue à la variable, changer le range pour changer la plage

MaPlage.Copy 'Fait la copie de la zone voulue
Workbooks.Add 'Ouvre un nouveau Fichier XL
ActiveSheet.Paste 'Colle la sélection à copier sur la feuille active, donc la nouvelle
'Fait la sauvegarde, la deuxième ligne en retrait reprend la variable avec la date
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\Administrateur\Mes documents\" _
& LaDate & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End Sub

Bonjour,

à tester,

Function USBD()
  Set fs = CreateObject("Scripting.FileSystemObject")
  Tmp = ""
  For Each d In fs.Drives
    If d.DriveType = 1 Then
      If d.IsReady Then Tmp = Tmp & d.DriveLetter
    End If
  Next
  USBD = Tmp
End Function

Sub test()
x = USBD
Debug.Print x
End Sub