Bug macro création de dossier

Bonjour,

J'ai récupéré une macro qui me permet à partir d'une liste de créer un ensemble de dossier avec des sous dossier ( merci à Kevin Brundu).

Je l'ai adapter à mon besoin et cela donne ceci :

Sub creer_dossier_sous_dossiers()

Dim ws_data As Worksheet
Dim lstrw As Long
Dim nom As String
Dim chemin_dossier As String
Dim chemin_sous_dossier As String

'identifier la feuille'
Set ws_data = Worksheets(1)

'dernière ligne'
lstrw = ws_data.Cells(Rows.Count, 1).End(xlUp).Row

'boucle sur les données'
For i = 2 To lstrw

nom = ws_data.Cells(i, 2)

chemin_dossier = "C:\Users\xxxxx\Desktop\plans\" & nom & "\"

'vérifier existence du dossier'
If Dir(chemin_dossier, vbDirectory) <> vbNullString Then
' dossier existe'
Else
'créer le dossier'
MkDir (chemin_dossier)

'ajout des sous dossiers'
chemin_sous_dossier = chemin_dossier & "Source\"
MkDir (chemin_sous_dossier)

chemin_sous_dossier = chemin_dossier & "Photos\"
MkDir (chemin_sous_dossier)

chemin_sous_dossier = chemin_dossier & "Archives\"
MkDir (chemin_sous_dossier)

End If
Next

End Sub

edit modo (H2so4) : code mis entre balises

La macro fonctionne et me créer les dossier. Le problème c'est que les dossier créer sont bugués. Quand je les supprimes, ils ne disparaissent pas et quand j'essaie de les déplacer, Windows 11 me dit que les dossier sont introuvables. je ne peux que supprimer les sous dossier.

Merci d'avance pour l'aide que vous pourrez m’apportez.

bonjour,

As-tu bien remplacé xxxxx par un nom d'utilisateur valide dans cette instruction ?

chemin_dossier = "C:\Users\xxxxx\Desktop\plans\" & nom & "\"

Bonjour,

En complément de la réponse précédente, pour ne pas avoir à remplacer xxxxxx, il est beaucoup plus judicieux d'utiliser la récupération automatique du profil utilisateur en modifiant l'instruction ainsi :

chemin_dossier = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\plans\" & nom & "\"