Créer un dossier pour chaque pdf

Sub Macro1()
Dim Chemin$
Chemin ="C:\Toto\" 'ici mettre le nom du dossier et le nom du lecteur
For Each sh In Sheets
    If Application.CountA(sh.Cells) > 0 Then
        Akw = sh.Name & ".pdf"
        sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Chemin & Akw
    End If
Next sh
End Sub

Option Explicit

'        http://msdn2.microsoft.com/en-us/library/bb762131.aspx
'
'        ERROR_BAD_PATHNAME         The pszPath parameter was set to a relative path.
'        ERROR_FILENAME_EXCED_RANGE The path pointed to by pszPath is too long.
'        ERROR_PATH_NOT_FOUND       The system cannot find the path pointed to by pszPath.
'                                   The path may contain an invalid entry.
'        ERROR_FILE_EXISTS          The directory exists.
'        ERROR_ALREADY_EXISTS       The directory exists.
'        ERROR_CANCELLED

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

Private Const ERROR_BAD_PATHNAME As Long = 161&
Private Const ERROR_FILENAME_EXCED_RANGE As Long = 206&
Private Const ERROR_PATH_NOT_FOUND As Long = 3&
Private Const ERROR_FILE_EXISTS As Long = 80&
Private Const ERROR_ALREADY_EXISTS As Long = 183&
Private Const ERROR_CANCELLED As Long = 1223&

Sub Tst_CreationDossier()
Dim sDossier As String, Rep As Long
    sDossier = "C:\Essai1\Essai2\Essai3\Essai4\Essai5"
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Sub

Sub Enregistrement()
Application.ScreenUpdating = True
Const DossierSauvegarde As String = "H:\Contrat Maintenance\"
Dim Nom_fichier As String
ReDim Feuilles(1 To 1)
Dim Compteur As Integer
Compteur = 0
Dim Feuille As Worksheet
For Each Feuille In Sheets
If Feuille.Range("F6").Value > 0 Then 'Ici la condition est que le nombre soit > 0
Compteur = Compteur + 1
ReDim Preserve Feuilles(1 To Compteur)
Feuilles(Compteur) = Feuille.Name
End If
Next Feuille
If Compteur > 0 Then Sheets(Feuilles).Copy
Nom_fichier = Sheets("SYNTHESE").Range("D8") & " " & Sheets("SYNTHESE").Range("D11")
ActiveWorkbook.SaveAs DossierSauvegarde & Nom_fichier & " ", FileFormat:=-4143, CreateBackup:=False
Call Tst_CreationDossier
End Sub




Sub Tst_CreationDossier()
Dim sh As Sheets
Dim Akw As Workbook
Dim sDossier As String, Rep As Long
    sDossier = "H:\Contrat Maintenance\pdf"
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
    For Each sh In Sheets ' on crée les pdf
    If Application.CountA(sh.Cells) > 0 Then
        Akw = sh.Name & ".pdf"
        sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sDossier & Akw
    End If
Next sh

End Sub

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

Sub Tst_CreationDossier()
Dim sh As Worksheet
Dim Akw As String
Dim sDossier As String, Rep As Long
    sDossier = "H:\Contrat Maintenance\pdf"
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
    For Each sh In Worksheets
        If Application.CountA(sh.Range("A1:A26")) > 0 Then
            Akw = sh.Name & ".pdf"
            sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sDossier & "\" & Akw
        End If
    Next sh
End Sub