Transformer une liste excel en dossiers windows

Option Explicit
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
Private Sub CreationDossier(sNomRep As String)
'issu d'un code de KiKi29 de http://www.excel-downloads.com/forum/110203-cr-er-dossier-enregistrer-dedans.html
    'ChDrive "D"
    SHCreateDirectoryEx 0&, sNomRep, 0&
End Sub

Sub Tst()
'issu d'un code de KiKi29 de http://www.excel-downloads.com/forum/110203-cr-er-dossier-enregistrer-dedans.html
Dim Rep As String, nomdeb As String, cel As Range, derl&, dos$
derl = Range("A65536").End(xlUp).Rows.Row
nomdeb = "C:\Dossiers Clients\"
For Each cel In Range("A2:A" & derl)
cel.Select
    Rep = ActiveCell.Value
    MsgBox Rep
    CreationDossier nomdeb & Rep & "\Nouveau Dossier"
    Next
End Sub

Option Explicit
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
(ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
Public t As Double, i&, nomdeb$, Rep$, chemin$, derl&
Private Sub CreationDossier(sNomRep As String)
SHCreateDirectoryEx 0&, sNomRep, 0&
End Sub

Sub Creer_Dossier()
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
derl = Range("A65536").End(xlUp).Row
nomdeb = "D:\Patients\"

On Error Resume Next
For i = 2 To derl
 'Noms des patients
Application.GoTo Range("A" & i)    
    Rep = ActiveCell.Value
    CreationDossier nomdeb & Rep & "\"
   'Nom du fichier  Facturation .doc
    chemin = nomdeb & Rep & "\" & Range("B1").Value & ".doc"   
    Set WordApp = CreateObject("Word.Application")
    WordApp.Visible = False
    Set WordDoc = WordApp.Documents.Add
    With WordApp.Selection
     ' Facture n°:  FC-0156-
    .Text = Range("B2").Value & i    
    .ParagraphFormat.Alignment = wdAlignParagraphRight
    .Font.Name = "Verdana"
    .Font.Size = 9
    .Font.Bold = True
End With
With WordDoc.Sections(1)
        .Footers(wdHeaderFooterPrimary).Range.Text = chemin
        .Footers(wdHeaderFooterPrimary).Range.Paragraphs.Alignment = wdAlignParagraphCenter
        '.Footers(wdHeaderFooterPrimary).PageNumbers.Add
    End With
    WordDoc.SaveAs chemin
WordApp.ActiveDocument.Close
Set WordApp = Nothing
If Rep = "" Then Exit Sub
 t = Timer + 1: Do Until Timer > t: DoEvents: Loop
    Next
End Sub