Création dossier et sous dossier avec test

Le 12/02/2020 à 12:05

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 !

Le 13/02/2020 à 07:36

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
Le 13/02/2020 à 08:27

Bonjour,

en complément de la réponse de i20100 et vu ton titre " Dossier et sous dossier "

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/

Le 13/02/2020 à 09:24

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
Le 13/02/2020 à 09:26

Bonjour,

Ôte les deux points après le ELSE

If bat > 4 And bat > 0 Then 
    dossier2 = "Immeuble"
    Else
         dossier2 = "pavillon"
    End If
Le 13/02/2020 à 09:38

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
Le 13/02/2020 à 09:40

il me dit exactement Sub ou Function non définie

Le 13/02/2020 à 09:42

Re,

si tu utilise la macro de i20100

vérifie l'écriture

Sub Créer_Dossier()

et non

CreerDossier
Le 13/02/2020 à 09:55

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é

Le 13/02/2020 à 09:57

Re,

Tu ferais mieux de placer ton classeur,

ça ira plus vite

Le 13/02/2020 à 10:24

que veux tu dire par "placer ton classeur" ? je veux créer les dossiers à la base où se situe le fichier de la macro.

Le 13/02/2020 à 10:29

Re,

dans ce cas place les macro complètes dans le post

Le 13/02/2020 à 10:38

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 & "\" & ?

Le 13/02/2020 à 10:50

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
Le 13/02/2020 à 11:20

ç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

Le 13/02/2020 à 11:29

Re,

modifie le nom du chemin

 NouveauDossierAvecSousDossiers =ThisWorkbook.path & "\dossier1\dossier2\dossier3"
Le 13/02/2020 à 11:42

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
Le 13/02/2020 à 11:46

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)

Le 13/02/2020 à 11:48

oui dans un fichier xlsm

Le 13/02/2020 à 11:53

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

Rechercher des sujets similaires à "creation dossier test"