XL 2016 Export PDF dans sous dossier

[KTM]

Bonsoir chers tous
je voudrais exporter ma plage A1:C10 au format PDF dans un sous dossier.
Ma macro doit:
- Créer un Dossier "Plage"
-Créer Un Sous dossier qui portera comme nom ma cellule E1
-Stocker mon Fichier PDF "TRIS" dans le Sous Dossier
J'ai élaboré ce qui suit mais je sais pas comment créer le sous dossier et le renommer
Merci de me guider

Sub SAVE()
Dim chemin As String
Dim fichier As String
             chemin = ThisWorkbook.Path & "\Plage\"
             If Dir(chemin, vbDirectory) = "" Then MkDir chemin
             With ActiveSheet
            
                .PageSetup.PrintArea = "$A$1:$C$10"
             fichier = .Range("A1")
                .ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
             chemin & fichier, Quality:=xlQualityStandard, _
             IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
            
          End With
End Sub

 

[kiki29]

Salut, voir par ici

 

[KTM]

Salut, voir par ici

merci c'est vu mais mon soucis c'est comment renommer automatiquement mon sous dossier . Je voudrais qu'il prenne pour nom la cellule E1.

 

[kiki29]

Re, une recherche te donne ceci parmi une myriade

 

[KTM]

Re, une recherche te donne ceci parmi une myriade

Encore Merci
J'ai essayé ce qui suit mais cela donne rien.
Prière me corriger

Sub SAVE()
Dim chemin As String
Dim fichier As String
             chemin = ThisWorkbook.Path & "\Plage\" & "\" & Cells(1, 5).Value & "\"
             If Dir(chemin, vbDirectory) = "" Then MkDir chemin
             With ActiveSheet
            
                .PageSetup.PrintArea = "$A$1:$C$10"
             fichier = .Range("A1")
                .ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
             chemin & fichier, Quality:=xlQualityStandard, _
             IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
            
          End With
End Sub

 

[kiki29]

Re, à toi de poursuivre en adaptant/élaguant pour ton contexte. A priori gère les doublons éventuels via un indice, vérifie la validité du nom de fichier.

Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, _
                                              ByVal pszPath As String, _
                                              ByVal lngsec As Long) As Long

Option Explicit

Private Function CreationDossier(sDossier As String) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function

Private Function NomFichierValide(sChaine As String) As Boolean
Dim i As Long
Const sCaracInterdits As String = """*/:<>?[\]|"
    NomFichierValide = True
    If Len(sChaine) = 0 Then
        NomFichierValide = False
        Exit Function
    End If
    For i = 1 To Len(sCaracInterdits)
        If InStr(sChaine, Mid$(sCaracInterdits, i, 1)) > 0 Then
            NomFichierValide = False
            Exit Function
        End If
    Next i
End Function

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

Sub Sauvegarde()
Dim sDossier As String
Dim sFichier As String
    sDossier = ThisWorkbook.Path & "\" & "Plage" & "\" & shParam.Cells(1, 5).Text
    CreationDossier sDossier

    With Feuil1
        .PageSetup.PrintArea = "$A$1:$C$10"
        sFichier = .Range("A1")
        If NomFichierValide(sFichier) Then
            sFichier = .Range("A1") & ".pdf"
            sFichier = RenommerFichier(sDossier, sFichier)
            .ExportAsFixedFormat Type:=xlTypePDF, _
                                 Filename:=sFichier, _
                                 Quality:=xlQualityStandard, _
                                 IncludeDocProperties:=True, _
                                 IgnorePrintAreas:=False, _
                                 OpenAfterPublish:=False
        Else
            Feuil1.Range("A1").Select
            MsgBox "Nom de fichier invalide", vbOKOnly + vbInformation
        End If
    End With
End Sub

 

[KTM]

Re, à toi de poursuivre en adaptant/élaguant pour ton contexte. A priori gère les doublons éventuels via un indice, vérifie la validité du nom de fichier.

Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, _
                                              ByVal pszPath As String, _
                                              ByVal lngsec As Long) As Long

Option Explicit

Private Function CreationDossier(sDossier As String) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function

Private Function NomFichierValide(sChaine As String) As Boolean
Dim i As Long
Const sCaracInterdits As String = """*/:<>?[\]|"
    NomFichierValide = True
    If Len(sChaine) = 0 Then
        NomFichierValide = False
        Exit Function
    End If
    For i = 1 To Len(sCaracInterdits)
        If InStr(sChaine, Mid$(sCaracInterdits, i, 1)) > 0 Then
            NomFichierValide = False
            Exit Function
        End If
    Next i
End Function

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

Sub Sauvegarde()
Dim sDossier As String
Dim sFichier As String
    sDossier = ThisWorkbook.Path & "\" & "Plage" & "\" & shParam.Cells(1, 5).Text
    CreationDossier sDossier

    With Feuil1
        .PageSetup.PrintArea = "$A$1:$C$10"
        sFichier = .Range("A1")
        If NomFichierValide(sFichier) Then
            sFichier = .Range("A1") & ".pdf"
            sFichier = RenommerFichier(sDossier, sFichier)
            .ExportAsFixedFormat Type:=xlTypePDF, _
                                 Filename:=sFichier, _
                                 Quality:=xlQualityStandard, _
                                 IncludeDocProperties:=True, _
                                 IgnorePrintAreas:=False, _
                                 OpenAfterPublish:=False
        Else
            Feuil1.Range("A1").Select
            MsgBox "Nom de fichier invalide", vbOKOnly + vbInformation
        End If
    End With
End Sub

Merci