.....
 if CreationDossier(CheminFichier) then
  ......
 Else
  MsgBox "Chemin d'accès introuvable"
  Exit Sub
 End If
     ......

Private Function CreationDossier(ByVal sPath As String) As Boolean
Dim i As Integer
Dim sTmp As String
Dim Ar() As String
     
    Ar = Split(sPath, "\" )
 
    sTmp = Ar(0)
    For i = LBound(Ar) + 1 To UBound(Ar)
        If Ar(i) <> "" Then
            sTmp = sTmp & "\" & Ar(i)
            On Error Resume Next
            MkDir sTmp
            On Error GoTo 0
        End If
    Next
 
    If Dir(sPath, vbDirectory) = "" Then
        CreationDossier = False
    Else
        CreationDossier = True
    End If
End Function

Option Explicit
 
Const DossierRacine As String = "C:\Faq\FaqVba\Exemples\ListeFichiers"
Const TypeFichier As String = "xls"
Dim r As Long,c As Long
Dim cpt As Long
 
Sub Liste()
    ShImport.Cells.Clear
    r = 1: c = 1: cpt = 0
    ListeFichiersDansDossier DossierRacine, False
End Sub
 
Private Sub ListeFichiersDansDossier(ByVal NomDossierSource As String, ByVal InclureSousDossiers As Boolean)
Dim FSO As Scripting.FileSystemObject
Dim DossierSource As Scripting.Folder, SousDossier As Scripting.Folder
Dim Fichier As Scripting.File
 
    Set FSO = New Scripting.FileSystemObject
    Set DossierSource = FSO.GetFolder(NomDossierSource)
 
    For Each Fichier In DossierSource.Files
        If UCase(FSO.GetExtensionName(Fichier.Name)) = UCase(TypeFichier) And Fichier.Name <> ThisWorkbook.Name Then
            With ShImport
                .Cells(r, c) = Fichier.Name
                .Cells(r, c + 1) = Fichier.ParentFolder
            End With
            cpt = cpt + 1
            r = r + 1
            Application.StatusBar = "Lecture noms : " & cpt
        End If
    Next Fichier
 
    If InclureSousDossiers Then
        For Each SousDossier In DossierSource.SubFolders
            ListeFichiersDansDossier SousDossier.Path, True
        Next SousDossier
        Set SousDossier = Nothing
    End If
 
    Set Fichier = Nothing
    Set DossierSource = Nothing
    Set FSO = Nothing
End Sub

Private Sub ListeFichiersDansDossier(ByVal NomDossierSource As String, ByVal InclureSousDossiers As Boolean)
Dim FSO As Scripting.FileSystemObject
Dim DossierSource As Scripting.Folder, SousDossier As Scripting.Folder
Dim Fichier As Scripting.File
Dim Ar() As String
 
    Set FSO = New Scripting.FileSystemObject
    Set DossierSource = FSO.GetFolder(NomDossierSource)
 
    For Each Fichier In DossierSource.Files
        If UCase(FSO.GetExtensionName(Fichier.Name)) = UCase(TypeFichier) And Fichier.Name <> ThisWorkbook.Name Then
            With ShImport
                .Cells(r, c) = Fichier.Name
                .Cells(r, c + 1) = Fichier.ParentFolder
                If InStr(Fichier.Name, "_" ) > 0 Then
                    Ar = Split(Fichier.Name, "_" )
                    .Cells(r, c + 2) = Ar(1)
                End If
            End With
            cpt = cpt + 1
            r = r + 1
            Application.StatusBar = "Lecture noms : " & cpt
        End If
    Next Fichier
 
    If InclureSousDossiers Then
        For Each SousDossier In DossierSource.SubFolders
            ListeFichiersDansDossier SousDossier.Path, True
        Next SousDossier
        Set SousDossier = Nothing
    End If
 
    Set Fichier = Nothing
    Set DossierSource = Nothing
    Set FSO = Nothing
End Sub