Sub CT_prevdosetssdoss()
Dim objShell As Object, objFolder As Object, oFolderItem As Object
Dim Chemin As String
racine = ChoixDossier() ' ou un répertoire C:\xxx e.g.
If racine = "" Then Exit Sub
Set fs = CreateObject("Scripting.FileSystemObject")
Set dossier_racine = fs.getfolder(racine)
For Each d In dossier_racine.SubFolders
Dim i
' Set objShell = CreateObject("Shell.Application")
' Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
Fichier = Dir(d & "\" & "*.xlsm")
i = 2
' On Error Resume Next
' Set oFolderItem = objFolder.Items.Item
' Chemin = oFolderItem.Path
' MsgBox Chemin
' ChDir Chemin
' Dim Fichier As String
'Boucle sur tous les fichiers xlsx du répertoire.
' Fichier = Dir("*.xlsm")
'Utilisez la syntaxe suivante pour boucler sur tous les types de fichiers:
'Fichier = Dir(Chemin & "*.*")
Do While Fichier <> ""
'écrit le résultat dans la fenêtre d'exécution (Ctrl+G).
If Fichier <> ThisWorkbook.Name Then
Workbooks.Open d & "\" & Fichier
Workbooks.Application.CalculateFullRebuild
Application.CalculateFull
Sheets("Page de garde").Application.CalculateFull
Sheets("Page de garde").Select
Range("E9:K17").Dirty
Range("E9:K17").Calculate
Dim nfichier As String, nfichier2 As String, intpos As Byte
nfichier = ActiveWorkbook.Name
intpos = InStrRev(nfichier, ".")
nfichier = Left(nfichier, intpos - 1)
nfichier2 = nfichier & ".pdf"
'MsgBox Fichier
Application.ScreenUpdating = False
Sheets(Array("Page de Garde", "Résultat AT", "Liste PM INCAP", "Liste PM INVAL", "Résultat Deces", "Liste PM RENTE", "Résultat Global", "Etude prestations", "Etude Nombre de jour et d'arrêt", "Lexique")).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=d & "\" & nfichier2, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
ActiveWorkbook.Close True
i = i + 1
End If
Fichier = Dir()
Loop
Next
MsgBox "transformation terminée"
End Sub