XL 2013 modifier code pour enregister en .PDF en plus

[grisan29]

Bonjour a tous et toutes
j'ai ce code qui fonctionne très bien en séparant les chemins d'enregistrement sous D:
mais je voudrais qu'il fasse la même chose mais en .PDF en supplément

Public Sub envoifacnue() 'sans les boutons et codes
      
    Dim F As Worksheet
    Dim Chemin As String
    Dim Client As String
    Dim Sh As Shape

      Set F = ThisWorkbook.Sheets(WS_FACTURE)
    Chemin = "D:\Facturation-v1s\Factureseule\Devis\" & Format(Date, "yyyy-mm") & "\"
    If Dir(Chemin, vbDirectory) = "" Then
        MkDir Chemin
    End If
      Select Case F.Range("D1")
      Case "DEVIS"
        Chemin = "D:\Facturation-v1s\factureseule\devis\" & Format(Date, "yyyy-mm") & "\"
    If Dir(Chemin, vbDirectory) = "" Then
        MkDir Chemin
    End If
      Case "FACTURE D'ACOMPTE"
        Chemin = "D:\Facturation-v1s\factureseule\facture acompte\" & Format(Date, "yyyy-mm") & "\"
    If Dir(Chemin, vbDirectory) = "" Then
        MkDir Chemin
    End If
      Case "FACTURE ACQUITTEE"
        Chemin = "D:\Facturation-v1s\factureseule\facture acquittée\" & Format(Date, "yyyy-mm") & "\"
    If Dir(Chemin, vbDirectory) = "" Then
        MkDir Chemin
    End If
      Case "FACTURE"
        Chemin = "D:\Facturation-v1s\factureseule\factures\" & Format(Date, "yyyy-mm") & "\"
    If Dir(Chemin, vbDirectory) = "" Then
        MkDir Chemin
    End If
      Case Else
        MsgBox "Impossibilité de déterminer le chemin" & vbCr & "Fin du programme"
        End
      End Select

      Client = F.Range("DOC_TITRE") & " - " & F.Range("DOC_CLIENT")

      Application.ScreenUpdating = False

      F.Copy
      With ActiveWorkbook
        With .Sheets(1)
          For Each Sh In .Shapes
            If Sh.Type <> msoPicture Then
              Sh.Delete
            End If
          Next Sh
    F.Cells(3, 1) = F.Cells(3, 1).Value
          .Cells.Copy
          .Range("A1").PasteSpecial Paste:=xlPasteValues
          .Range("A1").Select
        End With
        Application.DisplayAlerts = False  ' Si fichier identique présent : l'écrase sans alerte
      .SaveAs Filename:=Chemin & Client & ".xlsx"
        .Close
      End With
     
    End Sub

Merci d'avance

 

[grisan29]

Bonjour
j'ai modifier le même code mais j'ai un bug avec .pdf qui me dit reader RC ne peux ouvrir ce type de fichier

Sub Export_PDF()
    
    Dim F As Worksheet
    Dim CheminPDF As String
    Dim Client As String
    Dim Sh As Shape

      Set F = ThisWorkbook.Sheets(WS_FACTURE)
    Chemin = "D:\Facturation-v1s\Factureseule\Devis\" & Format(Date, "yyyy-mm") & "\"
    If Dir(Chemin, vbDirectory) = "" Then
        MkDir CheminPDF
    End If
      Select Case F.Range("D1")
      Case "DEVIS"
        CheminPDF = "D:\Facturation-v1s\factureseule\devis\DevisPDF\" & Format(Date, "yyyy-mm") & "\"
    If Dir(Chemin, vbDirectory) = "" Then
        MkDir CheminPDF
    End If
      Case "FACTURE D'ACOMPTE"
        CheminPDF = "D:\Facturation-v1s\factureseule\facture acompte\ACOMPTE\" & Format(Date, "yyyy-mm") & "\"
    If Dir(Chemin, vbDirectory) = "" Then
        MkDir CheminPDF
    End If
      Case "FACTURE ACQUITTEE"
        CheminPDF = "D:\Facturation-v1s\factureseule\facture acquittée\ACQUITTER\" & Format(Date, "yyyy-mm") & "\"
    If Dir(Chemin, vbDirectory) = "" Then
        MkDir CheminPDF
    End If
      Case "FACTURE"
        CheminPDF = "D:\Facturation-v1s\factureseule\factures\" & Format(Date, "yyyy-mm") & "\"
    If Dir(Chemin, vbDirectory) = "" Then
        MkDir CheminPDF
    End If
      Case Else
        MsgBox "Impossibilité de déterminer le chemin" & vbCr & "Fin du programme"
        End
      End Select
     
      Client = F.Range("DOC_TITRE") & " - " & F.Range("DOC_CLIENT")

      Application.ScreenUpdating = False

      F.Copy
      With ActiveWorkbook
        With .Sheets(1)
          For Each Sh In .Shapes
            If Sh.Type <> msoPicture Then
              Sh.Delete
            End If
          Next Sh
    F.Cells(3, 1) = F.Cells(3, 1).Value
          .Cells.Copy
          .Range("A1").PasteSpecial Paste:=xlPasteValues
          .Range("A1").Select
        End With
        Application.DisplayAlerts = False  ' Si fichier identique présent : l'écrase sans alerte
      .SaveAs Filename:=Chemin & Client & ".PDF"
        .Close
      End With
     

End Sub

c'est sur un mixage des 2 serai le top