Création dossier et sous dossier avec test
Bonjour, je suis trop léger en VBA pour le faire et le temps me presse ! voilà mon projet :
à la racine où se trouve mon fichier où je lance la macro je veux :
-tester si le dossier existe si non le créer avec nom de dossier :
& "\" & Range("C7").Value & " - " & Range("C16").Value & " - " & Range("C19").Value
- si la valeur de Range("C29") est comprise entre 1 et 4 => création sous-dossier "toto" (ou sélection si existant)
- si la valeur de Range("C29") est supérieur à 4 => création sous-dossier "titi" (ou sélection si existant)
- tester si le sous-dossier existe (dans toto ou titi) si non le créer avec nom de dossier : Range("C7").Value
- enregistrer le fichier avec le nom : "gaston " & Range("C7") & " - " & Range("C6") & ".xlsm"
merci aux passionnés-experts !
Bonjour,
je n'ai pas tout compris les conditions,
voici un exemple,
Sub Créer_Dossier()
test = "zaza"
dossier = ThisWorkbook.Path & "\" & test ' chemin à addapter
'vérifier si dossier exist, si le dossier est innexistant le créer
If Dir(dossier, vbDirectory) = "" Then MkDir dossier
End Sub
Bonjour,
en complément de la réponse de i20100
Alors attention il me semble que la fonction mkdir ne permet pas la création d'un dossier et du sous dossier
en même temps.
Si il n'y a qu'un dossier a créer alors ok sinon
https://excel-malin.com/codes-sources-vba/creation-dossiers-et-sous-dossiers-en-vba/
bonjour, voici ce que j'ai fait, il me met une erreur "else" sans if :
Sub dossiers_fichiers()
'par: Excel-Malin.com ( https://excel-malin.com )
On Error GoTo ExempleErreur
Dim NouveauDossierAvecSousDossiers As String
Dim dossier1 As String
Dim dossier2 As String
Dim bat As Integer
Dim dossier3 As String
Dim fichier As String
dossier1 = Thisworbook.Path & "\" & Range("C7").Value & " - " & Range("C16").Value & " - " & Range("C19").Value
bat = Sheets(Chantier).Range("C29")
If bat > 4 And bat > 0 Then dossier2 = "Immeuble"
Else: dossier2 = "pavillon"
End If
dossier3 = Thisworbook.Path & "\" & Range("C7").Value
fichier = "Fiche suivi chantier lot " & Sheets("Chantier").Range("C7") & " - " & Sheets("Chantier").Range("C6") & ".xlsm"
NouveauDossierAvecSousDossiers = "\dossier1\dossier2\dossier3"
CreerDossier (NouveauDossierAvecSousDossiers)
ActiveWorkbook.SaveAs Filename:=chemin & fichier, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Exit Sub
ExempleErreur:
MsgBox "Une erreur est survenue..."
End Sub
Bonjour,
Ôte les deux points après le ELSE
If bat > 4 And bat > 0 Then
dossier2 = "Immeuble"
Else
dossier2 = "pavillon"
End If
voilà, maintenant il me dit qu'il connait pas la fonction CreerDossier :
Sub dossiers_fichiers()
'par: Excel-Malin.com ( https://excel-malin.com )
On Error GoTo ExempleErreur
Dim NouveauDossierAvecSousDossiers As String
Dim dossier1 As String
Dim dossier2 As String
Dim bat As Integer
Dim dossier3 As String
Dim fichier As String
dossier1 = Thisworbook.Path & "\" & Range("C7").Value & " - " & Range("C16").Value & " - " & Range("C19").Value
bat = Sheets(Chantier).Range("C29")
If bat > 4 And bat > 0 Then
dossier2 = "Immeuble"
Else
dossier2 = "pavillon"
End If
dossier3 = Thisworbook.Path & "\" & Range("C7").Value
fichier = "Fiche suivi chantier lot " & Sheets("Chantier").Range("C7") & " - " & Sheets("Chantier").Range("C6") & ".xlsm"
NouveauDossierAvecSousDossiers = "\dossier1\dossier2\dossier3"
CreerDossier (NouveauDossierAvecSousDossiers)
ActiveWorkbook.SaveAs Filename:=NouveauDossierAvecSousDossiers & fichier, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Exit Sub
ExempleErreur:
MsgBox "Une erreur est survenue..."
End Sub
il me dit exactement Sub ou Function non définie
Re,
si tu utilise la macro de i20100
vérifie l'écriture
Sub Créer_Dossier()
et non
CreerDossier
effectivement en voulant aller vite j'avais oublié d'insérer le sub creerdossier....et donc maintenant ça me met directement le message d'erreur de la macro :"Une erreur est survenue...
sans pouvoir voir l'erreur en mode pas à pas détaillé
Re,
Tu ferais mieux de placer ton classeur,
ça ira plus vite
que veux tu dire par "placer ton classeur" ? je veux créer les dossiers à la base où se situe le fichier de la macro.
Re,
dans ce cas place les macro complètes dans le post
voici les codes :
celui que j'ai mis sans toucher :
Function CreerDossier(Chemin As String)
'par: Excel-Malin.com ( https://excel-malin.com )
On Error GoTo CreerDossierErreur
Dim PremierDossier As String
Dim CheminReseau As Boolean
Dim CheminPartielOK As String
Dim CheminPartiel, PartieDeChemin As Integer
Dim PartiesDeChemin As Variant
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If Len(Dir(Chemin, vbDirectory)) > 0 Then
CreerDossier = True
Exit Function
Else
'suppression du dernier backslash si présent
If Right(Chemin, 1) = Application.PathSeparator Then Chemin = Left(Chemin, Len(Chemin) - 1)
'vérificacion si chemin local ou réseau
If Left(Chemin, 2) = "\\" Then
CheminReseau = True
Else
CheminReseau = False
End If
'décomposition du chemin
If CheminReseau = False Then
PartiesDeChemin = Split(Chemin, Application.PathSeparator)
CheminPartielOK = ""
PremierDossier = LBound(PartiesDeChemin)
Else
PartiesDeChemin = Split(Replace(Chemin, "\\", ""), Application.PathSeparator)
CheminPartielOK = ""
PremierDossier = LBound(PartiesDeChemin) + 1
End If
'tests et créations de (sous)dossiers
For PartieDeChemin = PremierDossier To UBound(PartiesDeChemin)
For CheminPartiel = LBound(PartiesDeChemin) To PartieDeChemin
If CheminReseau = False Then
CheminPartielOK = CheminPartielOK & PartiesDeChemin(CheminPartiel) & Application.PathSeparator
Else
CheminPartielOK = CheminPartielOK & PartiesDeChemin(CheminPartiel) & Application.PathSeparator
End If
If CheminPartiel = PartieDeChemin Then
If CheminReseau = False Then
If FSO.FolderExists(CheminPartielOK) = False Then
MkDir CheminPartielOK
End If
Else
If Right(CheminPartielOK, 1) = Application.PathSeparator Then _
CheminPartielOK = Left(CheminPartielOK, Len(CheminPartielOK) - 1)
If Left(CheminPartielOK, 2) <> "\\" Then _
CheminPartielOK = "\\" & CheminPartielOK
If FSO.FolderExists(CheminPartielOK) = False Then
MkDir CheminPartielOK
End If
End If
End If
Next CheminPartiel
CheminPartielOK = ""
Next PartieDeChemin
End If
CreerDossier = True
Exit Function
CreerDossierErreur:
CreerDossier = False
End Function
et celui qui bloque :
Sub dossiers_fichiers()
'par: Excel-Malin.com ( https://excel-malin.com )
On Error GoTo ExempleErreur
Dim NouveauDossierAvecSousDossiers As String
Dim dossier1 As String
Dim dossier2 As String
Dim bat As Integer
Dim dossier3 As String
Dim fichier As String
dossier1 = Thisworbook.Path & "\" & Range("C7").Value & " - " & Range("C16").Value & " - " & Range("C19").Value
bat = Sheets(Chantier).Range("C29")
If bat > 4 And bat > 0 Then
dossier2 = "Immeuble"
Else
dossier2 = "pavillon"
End If
dossier3 = Thisworbook.Path & "\" & Range("C7").Value
fichier = "Fiche suivi chantier lot " & Sheets("Chantier").Range("C7") & " - " & Sheets("Chantier").Range("C6") & ".xlsm"
NouveauDossierAvecSousDossiers = "\dossier1\dossier2\dossier3"
CreerDossier (NouveauDossierAvecSousDossiers)
ActiveWorkbook.SaveAs Filename:=NouveauDossierAvecSousDossiers & fichier, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Exit Sub
ExempleErreur:
MsgBox "Une erreur est survenue..."
End Sub
est-ce qu'il faut pas que je vire dossier1 = Thisworbook.Path & "\" & ?
Re,
Regarde avec ceci
pour info l'écriture de Thisworbook.Path, c'est avec un K --> ThisWorkbook.path
et
Sheets(Chantier).Range("C29")
le nom de l'onglet avec des ""
Sheets("Chantier").Range("C29")
Option Explicit
Function CreerDossier(Chemin As String)
'par: Excel-Malin.com ( https://excel-malin.com )
On Error GoTo CreerDossierErreur
Dim PremierDossier As String
Dim CheminReseau As Boolean
Dim CheminPartielOK As String
Dim CheminPartiel, PartieDeChemin As Integer
Dim PartiesDeChemin As Variant
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If Len(Dir(Chemin, vbDirectory)) > 0 Then
CreerDossier = True
Exit Function
Else
'suppression du dernier backslash si présent
If Right(Chemin, 1) = Application.PathSeparator Then Chemin = Left(Chemin, Len(Chemin) - 1)
'vérificacion si chemin local ou réseau
If Left(Chemin, 2) = "\\" Then
CheminReseau = True
Else
CheminReseau = False
End If
'décomposition du chemin
If CheminReseau = False Then
PartiesDeChemin = Split(Chemin, Application.PathSeparator)
CheminPartielOK = ""
PremierDossier = LBound(PartiesDeChemin)
Else
PartiesDeChemin = Split(Replace(Chemin, "\\", ""), Application.PathSeparator)
CheminPartielOK = ""
PremierDossier = LBound(PartiesDeChemin) + 1
End If
'tests et créations de (sous)dossiers
For PartieDeChemin = PremierDossier To UBound(PartiesDeChemin)
For CheminPartiel = LBound(PartiesDeChemin) To PartieDeChemin
If CheminReseau = False Then
CheminPartielOK = CheminPartielOK & PartiesDeChemin(CheminPartiel) & Application.PathSeparator
Else
CheminPartielOK = CheminPartielOK & PartiesDeChemin(CheminPartiel) & Application.PathSeparator
End If
If CheminPartiel = PartieDeChemin Then
If CheminReseau = False Then
If FSO.FolderExists(CheminPartielOK) = False Then
MkDir CheminPartielOK
End If
Else
If Right(CheminPartielOK, 1) = Application.PathSeparator Then _
CheminPartielOK = Left(CheminPartielOK, Len(CheminPartielOK) - 1)
If Left(CheminPartielOK, 2) <> "\\" Then _
CheminPartielOK = "\\" & CheminPartielOK
If FSO.FolderExists(CheminPartielOK) = False Then
MkDir CheminPartielOK
End If
End If
End If
Next CheminPartiel
CheminPartielOK = ""
Next PartieDeChemin
End If
CreerDossier = True
Exit Function
CreerDossierErreur:
CreerDossier = False
End Function
Sub dossiers_fichiers()
'par: Excel-Malin.com ( https://excel-malin.com )
On Error GoTo ExempleErreur
Dim NouveauDossierAvecSousDossiers As String
Dim dossier1 As String
Dim dossier2 As String
Dim bat As Integer
Dim dossier3 As String
Dim fichier As String
dossier1 = ThisWorkbook.Path & "\" & Range("C7").Value & " - " & Range("C16").Value & " - " & Range("C19").Value
bat = Sheets("Chantier").Range("C29")
If bat > 4 And bat > 0 Then
dossier2 = "Immeuble"
Else
dossier2 = "pavillon"
End If
dossier3 = ThisWorkbook.Path & "\" & Range("C7").Value
fichier = "Fiche suivi chantier lot " & Sheets("Chantier").Range("C7") & " - " & Sheets("Chantier").Range("C6") & ".xlsm"
NouveauDossierAvecSousDossiers = "\dossier1\dossier2\dossier3"
CreerDossier (NouveauDossierAvecSousDossiers)
ActiveWorkbook.SaveAs Filename:=NouveauDossierAvecSousDossiers & fichier, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Exit Sub
ExempleErreur:
MsgBox "Une erreur est survenue..."
End Sub
ça commence à prendre forme ...mais :
ça m'a créé à la racine de C: dossier1/dossier2/dossier3/ et mon fichier se trouve dans dossier2 avec en début de nom dossier3Fiche....xlsm
Re,
modifie le nom du chemin
NouveauDossierAvecSousDossiers =ThisWorkbook.path & "\dossier1\dossier2\dossier3"
j'avais pas vu ta réponse que je l'avais déjà fait ! je deviens intelligent !
donc maintenant l'enregistrement se fait au bon endroit, par contre toujours avec les noms dossier1/dossier2/dossier3 et ça enregistre le fichier dans le dossier2 tjs
ça ne prend pas en compte mes valeurs string : je remets le code actuel :
Sub dossiers_fichiers()
'par: Excel-Malin.com ( https://excel-malin.com )
On Error GoTo ExempleErreur
Dim NouveauDossierAvecSousDossiers As String
Dim dossier1 As String
Dim dossier2 As String
Dim bat As Integer
Dim dossier3 As String
Dim fichier As String
dossier1 = Sheets("Chantier").Range("C7").Value & " - " & Sheets("Chantier").Range("C16").Value & " - " & Sheets("Chantier").Range("C19").Value
bat = Sheets("Chantier").Range("C29").Value
If bat > 4 And bat > 0 Then
dossier2 = "Immeuble"
Else
dossier2 = "pavillon"
End If
dossier3 = Sheets("Chantier").Range("C7").Value
fichier = "Fiche suivi chantier lot " & Sheets("Chantier").Range("C7") & " - " & Sheets("Chantier").Range("C6") & ".xlsm"
NouveauDossierAvecSousDossiers = ThisWorkbook.Path & "\dossier1\dossier2\dossier3"
CreerDossier (NouveauDossierAvecSousDossiers)
ActiveWorkbook.SaveAs Filename:=NouveauDossierAvecSousDossiers & fichier, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Exit Sub
ExempleErreur:
MsgBox "Une erreur est survenue..."
End Sub
Re,
Ta macro est bien dans un Classeur (fichier) Excel,
Alors post ton Classeur (ou fichier) dans le post
Pour info, un fichier peut être un bloc-note, une image, etc qui se trouve dans l'explorateur de windows
Pour parler EXCEL un classeur à l'extension XLS ou XLSX ou XLSM etc qui contient des onglets (ou feuille)
oui dans un fichier xlsm
Bonjour,
Oui d'après l'écriture il va créer dossier 1 dossier 2 dossier 3 puisque tu forces le texte avec les guillemets
NouveauDossierAvecSousDossiers = ThisWorkbook.Path & "\dossier1\dossier2\dossier3"
NouveauDossierAvecSousDossiers = ThisWorkbook.Path & "\" & dossier1 & "\" & dossier2 & "\" & dossier3