Sub AjouterDossier()
Dim xRacine, xRep, NouveauDossier
NouveauDossier = Trim(Range("a2"))
If Left(NouveauDossier, 1) <> "\" Then NouveauDossier = "\" & NouveauDossier
If NouveauDossier <> "\" Then
xRacine = ThisWorkbook.Path
ChDrive Left(xRacine, 1)
If Right(xRacine, 1) <> "\" Then xRacine = xRacine & "\"
xRep = Dir(xRacine & "*.*", vbDirectory)
On Error Resume Next
Do While xRep <> ""
If xRep <> "." And xRep <> ".." Then
If GetAttr(xRacine & xRep) = vbDirectory Then
MkDir xRacine & xRep & NouveauDossier
End If
End If
xRep = Dir
Loop
End If
MsgBox "C'est terminé.", vbInformation
End Sub