Macro pour enregistrer PDF avec version

Bonjour à tous et merci de votre aide,

J'ai créé un fichier excel de suivi.

Pour enregistrer les réponses sous format PDF, j'ai créé une macro permettant d'exporter en PDF avec un message de confirmation et un nom référencé, la macro fonctionne.

Sub Envoireponse()
CarryOn = MsgBox("Confirmez vous l'envoi de la réponse?", vbYesNo, "Kutools for Excel")
If CarryOn = vbNo Then: Exit Sub
If CarryOn = vbYes Then:
Dim LeNom As String
LeNom = "Reponse RD - " & " " & Range("BH7") & " " & Range("J6") & " " & Range("J7") & " " & Range("J8")
ActiveWorkbook.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=LeNom, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
Call effacerdonnées
End Sub

Ma demande concerne 2 éléments, je souhaiterai que celle-ci soit complété:

- un module permettant d'enregistrer le PDF à une adresse précise

- vérifier que le fichier n'existe pas déjà, si oui il incrémente avec un V1 puis V2, etc...

Merci à tous de votre aide car je n'y arrive pas

Bonjour,

Voici une possibilité de code

Sub Envoireponse()
  Dim LeChemin As String, LeNom As String, FicTrouve As String
  Dim Inc As Integer

  If MsgBox("Confirmez vous l'envoi de la réponse?", vbYesNo, "Kutools for Excel") = vbNo Then Exit Sub ' On sort de la sub
  LeChemin = "C:\Temp\"
  LeNom = "Reponse RD - " & " " & Range("BH7") & " " & Range("J6") & " " & Range("J7") & " " & Range("J8")
  FicTrouve = LeChemin & LeNom & "*.pdf"
  Do While Dir(FicTrouve) <> ""
    Inc = Inc + 1
    If InStrRev(LeNom, " v") >= Len(LeNom) - 3 Then
      LeNom = Left(LeNom, Len(LeNom) - 3) & " v" & Format(Inc, "00")
    Else
      LeNom = LeNom & " v" & Format(Inc, "00")
    End If
    FicTrouve = LeChemin & LeNom & ".pdf"
  Loop
  ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=LeChemin & LeNom, _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
  'Call effacerdonnées
End Sub

A+

Hello, ça marche presque parfaitement mais ca n'enregistre pas au niveau de Mr Christophe mais sur le bureau et m'ajoute Mr Christophe sur le nom du fichier ce que je ne veux pas

Dim LeChemin As String, LeNom As String, FicTrouve As String
Dim Inc As Integer
If MsgBox("Confirmez vous l'envoi de la réponse?", vbYesNo, "Kutools for Excel") = vbNo Then Exit Sub ' On sort de la sub
LeChemin = "C:\Users\cgaillard\Desktop\Mr Christophe"
LeNom = "Reponse RD - " & " " & Range("BH7") & " " & Range("J6") & " " & Range("J7") & " " & Range("J8")
FicTrouve = LeChemin & LeNom & "*.pdf"
Do While Dir(FicTrouve) <> ""
Inc = Inc + 1
If InStrRev(LeNom, " v") >= Len(LeNom) - 3 Then
LeNom = Left(LeNom, Len(LeNom) - 3) & " v" & Format(Inc, "00")
Else
LeNom = LeNom & " v" & Format(Inc, "00")
End If
FicTrouve = LeNom & ".pdf"
Loop
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=LeChemin & LeNom, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
' Call effacerdonnées
End Sub

Merci pour ton support c'est bien sympa

Re,

Attention, il ne faut pas oublier le dernier antislash

LeChemin = "C:\Users\cgaillard\Desktop\Mr Christophe\"

A+

Et bien que dire si ce n'est Merci !!! On en prends jamais le temps de remercier les gens. Très bonne journée à toi et à tous les membres ;-)