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
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...