VBA Excel : ouvrir dossier sur clé USB (lettre du lecteur variable)

Sub test()
Dim Chemin As String, T As String, S As Variant
Dim LecteurSource As String, A As Integer, Ok As Boolean

'***********Variable à renseigner*********
Chemin = "Outils\Dossier A\"
'*******************************************

T = RemovableDisk(LecteurSource)
If InStr(1, T, ",", vbTextCompare) > 0 Then
    S = Split(T, ",")
Else
    If Dir(T & Chemin, vbDirectory) <> "" Then
        ChDrive Left(T, 1)
        ChDir T & Chemin
        Ok = True
        MsgBox "Répertoire courant : " & T & Chemin
        Exit Sub
    Else
        MsgBox "Chemin """ & T & Chemin & _
            """ inexistant sur cette clé : " & T
        Exit Sub
    End If
End If
For A = LBound(S) To UBound(S)
    If Dir(S(A) & Chemin, vbDirectory) Then
        Application.DefaultFilePath = Dir(S(A) & Chemin)
        MsgBox "Répertoire courant : " & T & Chemin
        Ok = True
        Exit Sub
    End If
Next
If Ok = False Then
    MsgBox "Chemin """ & T & Chemin & _
        """ inexistant sur cette clé : " & T
End If
End Sub
'-------------------------------------------------------
Function RemovableDisk(MonLecteur As String)

Dim strComputer As String, objWMIService As Object
Dim Objdisk As Object, colDisks As Object

strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
    & "{impersonationLevel=impersonate}!\\" & _
        strComputer & "\root\cimv2")
Set colDisks = objWMIService.ExecQuery _
    ("Select * from Win32_LogicalDisk")
For Each Objdisk In colDisks
    '2 constante numérique pour disque dur "removable"
    If Objdisk.DriveType = 2 Then
        RemovableDisk = RemovableDisk & Objdisk.Name & "\" & ","
    End If
Next
If RemovableDisk <> "" Then
    RemovableDisk = Left(RemovableDisk, Len(RemovableDisk) - 1)
End If
End Function

Private Declare Function GetVolumeInformation Lib "Kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Function GetVolumeName(ByVal cDrive As String) As String
' http://www.codyx.org/snippet_recuperer-nom-attribue-lecteur-disque-cle-etc_863.aspx
' cDrive = CHAR (lettre)  de A à Z
    Dim sBuffer As String
    Dim iEnd As Integer

    sBuffer = Space$(255)
    GetVolumeInformation cDrive & ":\", sBuffer, Len(sBuffer), 0&, 0&, 0&, vbNullString, 0&
    iEnd = InStr(1, sBuffer, vbNullChar)
    If iEnd Then GetVolumeName = Left$(sBuffer, iEnd - 1)
End Function

Function lettreLecteur(nomLecteur As String) As String
    Dim l As Long
    For l = 1 To 26
        If GetVolumeName(Chr(64 + l)) = nomLecteur Then
            lettreLecteur = Chr(l + 64)
            Exit For
        End If
    Next l
End Function

Sub test()
    Dim r As String, nomLecteur  As String
    nomLecteur = "KINGSTON"
    r = lettreLecteur(nomLecteur)
    If r <> "" Then
        MsgBox ("Lettre du lecteur '" & nomLecteur & "' = " & r)
    Else
        MsgBox ("Lecteur '" & nomLecteur & "' non trouvé.")
    End If
End Sub

If Objdisk.DriveType = 2 Then
    RemovableDisk = RemovableDisk & Objdisk.Name & "\" & ","
End If

If Objdisk.DriveType = 2 And Objdisk.FreeSpace > 0 Then
    RemovableDisk = RemovableDisk & Objdisk.Name & "\" & ","
End If