Résolu Enregistrer des onglets en pdf sans écraser

Lisette

XLDnaute Junior
Bonjour à tous !!
J'espère que le lundi n'est pas trop dur pour vous... Pour moi, c'est difficile !!! o_O 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 ?
VB:
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

XLDnaute Barbatruc
Bonjour Lisette, bonjour le forum,

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

VB:
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

XLDnaute Barbatruc
Supporter XLD
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

XLDnaute Junior
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é ;(
 

Lisette

XLDnaute Junior
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

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

sylvanu

XLDnaute Barbatruc
Supporter XLD
J'ai fait ça, ça à l'air de passer :
VB:
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

XLDnaute Junior
Du coup, j'ai opté pour la méthode "date et heure"
VB:
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

XLDnaute Barbatruc
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

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

kiki29

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


VB:
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
 

Fichiers joints

Dernière édition:

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas