Enregistrer des onglets en pdf sans écraser

[Lisette]

Bonjour à tous !!
J'espère que le lundi n'est pas trop dur pour vous... Pour moi, c'est difficile !!! 😵 hehe

Je bloque sur une macro !
Son but : enregistrer plusieurs onglets au format .pdf dans le dossier par défaut (j'ai plusieurs utilisateurs différents)

Et ça fonctionne bien. Néanmoins, quand j'enregistre, si j'ai un fichier existant, elle le remplace sans rien me dire la coquine !
Je sais vaguement qu'il faut insérer une routine de test d'existence de fichier dans mon code, mais je bloque... Y aurait-il une bonne âme pour me corriger s'il vous plaît ?

Sub Macro3()
' Macro3 Macro
Dim sFilename As String
NomFichier = Sheets("IMPRESSION").Range("E15").Value
Sheets(Array("Infos générales", "01", "02", "03", "04", "05", "06", "07", "08", "09", "10")).Select
ActiveSheet.ExportAsFixedFormat _
             Type:=xlTypePDF, _
             Filename:=NomFichier & ".pdf", _
             Quality:=xlQualityStandard, _
             IncludeDocProperties:=True, _
             IgnorePrintAreas:=False, _
             OpenAfterPublish:=True
Sheets("IMPRESSION").Select
Range("B11:I11").Select
End Sub

Par avance un grand merci et bonne journée !

 

[Robert]

Bonjour Lisette, bonjour le forum,

Ton code modifié. Est-ce que ça convient ?

Sub Macro3()
Dim NomFichier As String
Dim CA As String

NomFichier = Sheets("IMPRESSION").Range("E15").Value
CA = ThisWorkbook.Path & "\" 'ou CA = "le_chemin_d_accès_du_dossier_par_défaut\"
F = Dir(CA & NomFichier & ".pdf")
Do While F <> ""
    If MsgBox("Un fichier PDF existe déjà avec ce nom : " & NomFichier & " ! Voulez-vous continuer ?", vbYesNo, "ATTENTION") = vbNo Then Exit Sub
    F = Dir
Loop
Sheets(Array("Infos générales", "01", "02", "03", "04", "05", "06", "07", "08", "09", "10")).Select
ActiveSheet.ExportAsFixedFormat _
             Type:=xlTypePDF, _
             Filename:=NomFichier & ".pdf", _
             Quality:=xlQualityStandard, _
             IncludeDocProperties:=True, _
             IgnorePrintAreas:=False, _
             OpenAfterPublish:=True
Sheets("IMPRESSION").Select
Range("B11:I11").Select
End Sub

 

[sylvanu]

Bonjour Lisette, Robert,
En plus du code de Robert, on peut ajouter à la fin du nom de fichier la date d'enregistrement. Ce qui limite les possibilités de nom de fichiers identiques.

 

[Lisette]

Bonjour à tous les deux et merci pour vos réponses.
Pour une raison qui m'échappe, aucun msgbox ne s'affiche et mon fichier continue d'être écrasé ;(

 

[Robert]

Re,

Tu as bien spécifier le chemin d'accès CA ?

 

[Lisette]

J’ai laisse en CA : Thisworkbook.path pour que ça enregistre dans le même dossier que mon fichier de base, qui est le bureau, mais celui-ci va s’enregistrer dans mes documents.
Je ne peux pas préciser quel sera le dossier par défaut de chaque utilisateur…: /

 

[Lisette]

Au pire, y a-t-il possibilité de ne pas spécifier et que chaque utilisateur puisse spécifier lors de l’enregistrement ?

 

[sylvanu]

Robert, en pas à pas, ça saute le module Do...Loop, F est vide et CA="\". C'est ThisWorkbook.Path qui coince.

 

[sylvanu]

J'ai fait ça, ça à l'air de passer :

NomFichier = Sheets("IMPRESSION").Range("E15").Value
CA = CurDir & "\"
F = CA & NomFichier & ".pdf"

Robert, je ne sai pas si ça fait exactement la même chose.

 

[Lisette]

Du coup, j'ai opté pour la méthode "date et heure"

Sub Macro3()
Dim NomFichier As String
Dim CA As String

NomFichier = Sheets("IMPRESSION").Range("E15").Value
Sheets(Array("Infos générales", "01", "02", "03", "04", "05", "06", "07", "08", "09", "10")).Select
ActiveSheet.ExportAsFixedFormat _
             Type:=xlTypePDF, _
             Filename:=NomFichier & Format(Date, "dd-mm-yyyy") & "_" & Format(Time, "hhmm") & ".pdf", _
             Quality:=xlQualityStandard, _
             IncludeDocProperties:=True, _
             IgnorePrintAreas:=False, _
             OpenAfterPublish:=True
            
MsgBox "Fichier enregistré dans les Documents de : " & ActiveWorkbook.UserStatus(1, 1), vbOKOnly + vbInformation, "PLAN DE PREVENTION SAUVEGARDE"

Sheets("IMPRESSION").Select
Range("B11:I11").Select
End Sub

 

[Robert]

Re,

Robert, en pas à pas, ça saute le module Do...Loop, F est vide et CA="\". C'est ThisWorkbook.Path qui coince.

Pas chez moi. Si F est vide on n'a pas la question de continuer ou pas mais cela signifie qu'il n'existe pas de fichier PDF avec le même nom. Donc pas d'écrasement. De plus, il semblerait que CA = ThisWorkbook.path & "\" soit le plus simple à gérer.
J'ai procédé de la sorte:
- 1 dossier contenant le fichier avec la macro que j'ai nommé Lisette_ED_v01.xlsm avec un onglet nommé IMPRESSION
- dans se dossier 3 fichiers PDF : fichier1.pdf, fichier2.pdf, fichier3.pdf
- Si dans E15 de l'onglet IMPRESSION, je tape fichier1 ou fichier2 ou fichier3 et que j'envoie la macro j'ai toujours le message : Voulez-vous continuer ?... Le fichier est écrasé uniquement si je dis oui. Si je veux poursuivre il me fait taper un autre nom dans E15 et relancer la macro...
- Sinon la macro s'exécute jusqu'au bout en créant un nouveau fichier pdf...

 

[Robert]

Re,

Perso, je suis plus F=Dir(CA & NomFichier) que CA = CurDir & "\" mais si ça marche mieux comme ça, garde le...
Arf ça va trop vite.... Oui avec la date et l'heure c'est encore mieux quand on aime les noms de fichier à rallonge...

 

[Lisette]

En biaisant un peu, ça va, je ne rajoute que deux chiffres
Quoi qu'il en soit, merci à tous 😉

 

[kiki29]

Salut, voir ici, le dernier post intitulé : Impression de certaines Feuilles d'un classeur via un tableau dans un seul Pdf résultant. Cela date de 2007...
En lui adjoignant la procédure ci-dessous à l'endroit idoine : ceci permettant ce qui est en pj.

Étant définitivement fâché avec le Belge et ses mignons de couchette de Developpez.com, j'ai supprimé l'ensemble des téléchargements ( 110 au bas mot ), d'où les liens internes de téléchargement caduques. Ces téléchargements sont toujours disponibles sur mon PC, si quelqu'un en fait la demande.

Private Function RenommerFichier(sDossier As String, sNomfichier As String) As String
Dim sNouveauNom As String
Dim sPre As String, sExt As String
Dim i As Long
Dim FSO As Object

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(sDossier & "\" & sNomfichier) Then
        sNouveauNom = sNomfichier
        sPre = FSO.GetBaseName(sNomfichier)
        sExt = FSO.GetExtensionName(sNomfichier)

        i = 0
        While FSO.FileExists(sDossier & "\" & sNouveauNom)
            i = i + 1
            sNouveauNom = sPre & Chr(40) & Format(i, "000") & Chr(41) & Chr(46) & sExt
        Wend
        sNomfichier = sNouveauNom
    End If
    Set FSO = Nothing

    RenommerFichier = sDossier & "\" & sNomfichier
End Function

 

[Robert]

Re,

En biaisant un peu, ça va, je ne rajoute que deux chiffres

C'est vrai que ça donne 'ach'ment envie de biaiser...