Creation dossier et copie fichiers

Sub Transfert_dossiers()
Dim CheminSource As String, CheminDest As String 'Emplacements des dossiers source et destination
Dim DossSource As String, DossDest1 As String, DossDest2 As String, BoolErr As Boolean
Dim i As Long, FSO As Object, Fl As Object
    CheminSource = "C:\" 'A adapter : chemin des dossiers sources
    CheminDest = "C:\" 'A adapter : chemin des dossiers destination
    Set FSO = CreateObject("Scripting.FilesystemObject")
    With ThisWorkbook.Worksheets("Feuil1") 'Feuille contenant les données pour le transfert
    For i = 1 To .Range("A" & .Rows.Count).End(xlUp).Row 'Pour chaque ligne de la liste
            BoolErr = False
            DossSource = .Range("A" & i).Value 'On note le nom des dossiers de la ligne pour le traitement
            DossDest1 = .Range("B" & i).Value
            DossDest2 = .Range("C" & i).Value
            On Error GoTo ErrDepl
            If FSO.folderexists(CheminSource & DossSource) Then 'On vérifie l'existence du dossier source
                If Not FSO.folderexists(CheminDest & DossDest1) Then 'On crée le 1er dossier de destination
                    FSO.createfolder CheminDest & DossDest1
                End If
                If Not FSO.folderexists(CheminDest & DossDest1 &  "\" & DossDest2) Then 'On crée le second dossier de destination
                    FSO.createfolder CheminDest & DossDest1 & "\" & DossDest2
                End If
                For Each Fl In FSO.getfolder(CheminSource & DossSource).Files 'On déplace tous les fichiers
                    FSO.movefile CheminSource & DossSource & "\"  & Fl.Name, CheminDest & DossDest1 & "\" & DossDest2  & "\"
                Next
            Else
                .Range("D" & i).Value = "Dossier source non trouvé" 'Gestion erreur dossier source inexistant
            End If
            On Error GoTo 0
FinDepl:
            If BoolErr Then .Range("D" & i).Value = "Erreur lors de  la création de dossier ou du déplacement des fichiers" 'Gestion erreur  dans la création des dossiers ou le déplacement des fichiers
        Next i
    End With
    Set Fl = Nothing
    Set FSO = Nothing
    Exit Sub
ErrDepl:
    BoolErr = True
    Resume FinDepl
End Sub