VBA - enregistrer plusieurs fichiers dans un même répertoire

Bonjour à tous !

Aujourd'hui, je finalise la macro qui m'a pourrie la vie durant ces deux dernière semaines Et j'ai omis un détail quant à l'enregistrement des fichiers.

Quand je lance ma macro, elle génère automatiquement des fiches en format PDF dans le dossier où se trouve le fichier de travail.

Seulement, je voudrais qu'elle créé un dossier spécifique à chaque fois que je lance la macro.

Par exemple, je décide de lancer la créations des fiches pour les EPCI de la Drôme, elle va me créer dans mon répertoire, un dossier "EPCI Drôme" dans laquelle elle stockera l'ensemble des fiches. Si je lance la création des fiches pour les communes de l'EPCI X, elle va me créer dans mon répertoire, un dossier "EPCI X"

Merci par avance !

Je vous joins mon code, au cas où !

Sub Générer()
Dim c, fC, fD
    Set fD = ActiveSheet
    For Each c In Range("B37:B" & Range("B100").End(xlUp).Row)      

        If c.Value <> "" Then                                        
            Sheets("FicheTerr").Visible = True                          
            Sheets("FicheTerr").Copy Before:=Sheets(1)                
            ActiveSheet.Name = c.Offset(0, 0)                         
            Set fC = ActiveSheet                                      
            Sheets("FicheTerr").Visible = True
            Sheets("SELECTION").Range("H6") = "'" & c.Value                    
            Sheets("SELECTION").Range("H15") = "'" & c.Offset(0, 4).Value         
            Sheets("SELECTION").Range("H24") = "'" & c.Offset(0, 5).Value          

            'On enregistre la nouvelle feuille dans un fichier PDF

            ActiveSheet.Copy
                ActiveWorkbook.Colors = Workbooks("Base de données test.xlsm").Colors
            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & c.Offset(0, 1)
            ActiveWindow.Close False
            Application.DisplayAlerts = False
            ActiveSheet.Delete
            Application.DisplayAlerts = True
        End If
    Next c

    'On remet les formules en H6, H15 et H22
Sheets("SELECTION").Range("H6").FormulaR1C1 = _
 "=IF(RC[-6]=""EPCI 2013"",VLOOKUP(R[-3]C[-6],listes!R2C25:R70C26,2,FALSE),IF(RC[-6]=""DROME"",""DROME"",IF(RC[-6]=""ARDECHE"",""ARDECHE"",INDEX(BASE!R3C1:R1053C1,MATCH(SELECTION!RC[-6],BASE!R3C3:R[1047]C3,0)))))"

Sheets("SELECTION").Range("H15").FormulaR1C1 = _
        "=IF(RC[-6]=""EPCI 2013"",VLOOKUP(R[-3]C[-6],listes!R2C25:R70C26,2,FALSE),IF(RC[-6]=""DROME"",""DROME"",IF(RC[-6]=""ARDECHE"",""ARDECHE"",INDEX(BASE!R3C1:R1053C1,MATCH(SELECTION!RC[-6],BASE!R3C3:R[1038]C3,0)))))"

Sheets("SELECTIOn").Range("H24").FormulaR1C1 = _
        "=IF(RC[-6]=""EPCI 2013"",VLOOKUP(R[-3]C[-6],listes!R2C25:R70C26,2,FALSE),IF(RC[-6]=""DROME"",""DROME"",IF(RC[-6]=""ARDECHE"",""ARDECHE"",INDEX(BASE!R3C1:R1053C1,MATCH(SELECTION!RC[-6],BASE!R3C3:R[1029]C3,0)))))"
End Sub

Bonjour,

voir l'instruction MkDir …

Bonjour !

Je te remercies de ton aide.

J'ai donc intégré l'instruction MkDir :

Sub Générer()
Dim c, fC, fD, doc
    Set fD = ActiveSheet
    For Each c In Range("B37:B" & Range("B100").End(xlUp).Row)          
    doc = Range("B34").Value
    MkDir "G:\Nouveau dossier\Macro fiche terr\Sauvegarde du 16.02" & doc

        If c.Value <> "" Then                                           
            Workbooks("fiches communales.xlsm").Sheets("FicheTerr").Visible = True
            Workbooks("fiches communales.xlsm").Sheets("FicheTerr").Copy Before:=Sheets(1)
            ActiveSheet.Name = c.Offset(0, 0)                           
            Set fC = ActiveSheet
            Sheets("FicheTerr").Visible = True
            Sheets("SELECTION").Range("H6") = "'" & c.Value               
            Sheets("SELECTION").Range("H15") = "'" & c.Offset(0, 4).Value  
            Sheets("SELECTION").Range("H24") = "'" & c.Offset(0, 5).Value   

            'On enregistre la nouvelle feuille dans un fichier PDF

            ActiveSheet.Copy
                ActiveWorkbook.Colors = Workbooks("fiches communales.xlsm").Colors
            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & c.Offset(0, 1)
            ActiveWindow.Close False
            Application.DisplayAlerts = False
            ActiveSheet.Delete
            Application.DisplayAlerts = True
        End If
    Next c

    'On remet les formules en H6, H15 et H22
Sheets("SELECTION").Range("H6").FormulaR1C1 = Range("H8").FormulaR1C1       
Sheets("SELECTION").Range("H15").FormulaR1C1 = Range("H17").FormulaR1C1     
Sheets("SELECTION").Range("H24").FormulaR1C1 = Range("H26").FormulaR1C1   
End Sub

Quand j’exécute la macro, une erreur se produit à la ligne suivante :

MkDir "G:\Nouveau dossier\Macro fiche terr\Sauvegarde du 16.02" & doc

"Erreur d'exécution '75': Erreur d'accès Chemin/Fichier"

Créer les dossiers un niveau à la fois pour voir …

C'est à dire que mon dossier "sauvegarde du 16.02" est déjà créé puisqu'il y a mon fichier de travail excel dedans..

Je up le sujet car je suis toujours bloquée.

Sub Générer()
Dim c, fC, fD
    Set fD = ActiveSheet
    ChDir "G:\Nouveau dossier\Macro fiche terr\Sauvegarde du 16.02"     'Chemin du dossier
    MkDir Range("B34").Value

J'ai trouvé en faisant des recherches sur internet le code ci-dessus qui permet de déclarer le chemin d'accès puis le nom du dossier à créer. "Parfait" me disais-je, mais l'erreur sur le MkDir persiste : erreur d'accès Chemin/Fichier.

Je précise que dans mon répertoire actuel, je n'ai aucuns dossiers de créés.

Merci pour votre aide future !

Marc L a écrit :

Créer les dossiers un niveau à la fois pour voir …

Créer d'abord le dossier de niveau 1 (G:\Nouveau dossier) puis le dossier de niveau 2 (Macro fiche terr) puis …

Bref, niveau par niveau comme c'est pourtant indiqué dans l'aide VBA !

Sinon passer par une bibliothèque Windows …

Tu peux utiliser cette fonction pour créer des dossiers/sous-dossiers d'un seul coup...

Mets ton chemin complet comme paramètre de cette fonction, elle fera le reste.

Function CreateFolder(FolderPath As String)
On Error GoTo CreateFolderError

If Len(Dir(FolderPath, vbDirectory)) > 0 Then
CreateFolder = True
Exit Function
Else
        If Right(FolderPath, 1) = Application.PathSeparator Then FolderPath = Left(FolderPath, Len(FolderPath) - 1)
        PathParts = Split(FolderPath, Application.PathSeparator)

        For PathPart = LBound(PathParts) To UBound(PathParts)

            For PartialPath = LBound(PathParts) To PathPart
                PartialPathOK = PartialPathOK & PathParts(PartialPath) & Application.PathSeparator
                If PartialPath = PathPart Then
                    If Len(Dir(PartialPathOK, vbDirectory)) = 0 Then
                        MkDir PartialPathOK
                    End If
                End If
            Next PartialPath
            PartialPathOK = ""
        Next PathPart
End If

CreateFolder = True
Exit Function
CreateFolderError:
CreateFolder = False
End Function

Bonjour !

Je vous remercie de votre aide apportée, mon dossier se créé bien.

Maintenant, je coince au niveau de l'enregistrement des fichiers.

Mon souhait était de générer des PDF. Jusque là, c'est ok. Mon code actuel génère les PDF et les enregistre dans le dossier où se trouve mon fichier de travail. Or, je souhaiterai que les PDF se retrouvent dans le dossier nouvellement créé.

Si dessous, la partie du code concernant la génération et l'enregistrement des PDF.

 ActiveSheet.Copy
                ActiveWorkbook.Colors = Workbooks("fiches communales.xlsm").Colors
            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=c.Offset(0, 1)
            ActiveWindow.Close False
            Application.DisplayAlerts = False
            ActiveSheet.Delete
            Application.DisplayAlerts = True

Je vous remercie par avance pour votre aide.

EDIT : Problème résolu ! J'ai trouvé une solution.

Du coup, le sujet est résolu.

Avec plaisir...