Microsoft 365 VBA problème formule pour sauvegarder en PDF et pour imprimerPF

[Mr.Adrien]

Bonjour j'aimerais créer un bouton avec une macro sur ma feuille Excel pour sauvegarder en format PDF en une seul page et uniquement certaine cellule et non toute la page avec un nom différent à chaque appui sur le bouton sauvegarde.

1er problème de ma macro il ne sauvegarde pas dans le fichier PDF uniquement les cellules concernées et 2ieme problème il écrase le fichier quand je sauvegarde une deuxième fois car le nom reste le même.

Et j'aimerais créer aussi un bouton imprimer pour imprimer uniquement certaine cellules (les mêmes que le bouton sauvegarde) mais la macro va s'arrêter à la sélection de l'imprimante et non imprimer le document si possible.

Cordialement...
Sub MacroSauv()
'
' MacroSauv Macro
'

'
Range("A1:K53").Select
Range("K1").Activate
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
"/Users/anas/Desktop/Pojet Excel/Demande d'inscription et de réinscription.pdf" _
, Quality:=xlQualityMinimum, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
End Sub

 

[kiki29]

Salut, 3 possibilités, l'une via un indice une autre via date heure et encore une via les noms/prénoms/date de naissance + indice si doublons ( à priori la + cohérente )

Option Explicit

Sub MacroSauv_01()
Dim sDossier As String, sNom As String
Dim sFinal As String

    sDossier = ThisWorkbook.Path
    sNom = "Demande d'inscription et de réinscription.pdf"

    sFinal = RenommerFichier(sDossier, sNom)

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                    FileName:=sFinal, _
                                    Quality:=xlQualityMinimum, _
                                    IncludeDocProperties:=True, _
                                    IgnorePrintAreas:=False, _
                                    OpenAfterPublish:=False
End Sub

Sub MacroSauv_02()
Dim sDossier As String, sNom As String
Dim sFinal As String

    sDossier = ThisWorkbook.Path
    sNom = "Demande d'inscription et de réinscription"

    sNom = sNom & " " & Format(Now, "dd mmm yy hhmmss")
    sFinal = sDossier & "\" & sNom

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                    FileName:=sFinal, _
                                    Quality:=xlQualityMinimum, _
                                    IncludeDocProperties:=True, _
                                    IgnorePrintAreas:=False, _
                                    OpenAfterPublish:=False
End Sub

Sub MacroSauv_03()
Dim sDossier As String, sNomFichier As String
Dim sNom As String, sPrenom As String, sDate As String
Dim sFinal As String

    sDossier = ThisWorkbook.Path
    sNomFichier = "Demande d'inscription et de réinscription"

    sNom = sFormulaire.Range("C9")
    sPrenom = sFormulaire.Range("H9")
    sDate = sFormulaire.Range("D10")

    sNomFichier = sNomFichier & " " & sNom & " " & sPrenom & " " & Replace(sDate, "/", "_") & ".pdf"
    sFinal = RenommerFichier(sDossier, sNomFichier)

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                    FileName:=sFinal, _
                                    Quality:=xlQualityMinimum, _
                                    IncludeDocProperties:=True, _
                                    IgnorePrintAreas:=False, _
                                    OpenAfterPublish:=False
End Sub

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

 

[Mr.Adrien]

Merci beaucoup