Microsoft 365 Vba Impression PDF

[eric72]

Bonjour à tous,
Voilà plus d'un jour que je cherche une solution à ce problème, sans succès.
J'ai un fichier avec 6 onglets et j'aimerais, avec une macro imprimer ces 6 feuilles en PDF avec un nom de fichier pour chaque onglet
- Nom du Pied de page Exemple Stock Bx 31/03/2022
avec une sélection de l'année correspondant à un dossier de l'année avec par exemple
NomDossier = Application.InputBox("Saisir Année d'Archive:", "Année ?", Year(Date), 1)
et tout cela en une fois avec 6 fichiers pdf dans le dossier qui se nomme par exemple "2022" avec un chemin par exemple
Chemin = "C:\Users\Utilisateur\OneDrive - Fiteco\JCR\INVENTAIRE\" & NomDossier & "\"
Je tourne en rond et ne m'en sors pas, quelqu'un a-t-il la solution à mon problème
Merci beaucoup pour le temps consacré
Eric

 

[kiki29]

Salut, peut-être via liste contributions PDF

 

[eric72]

Bonjour KiKi29,
Merci pour cette réponse mais je n'y comprends pas grand chose!!!
Si au moins j'avais la solution pour une feuille je pourrais ensuite le dupliquer sur les autres.
Merci
Eric

 

[kiki29]

Re, un début, à toi de poursuivre.

Option Explicit

Sub Tst()
Dim Wsh As Worksheet
Dim sChemin As String
Dim FSO As Object, i As Long

    Application.StatusBar = ""
    Application.ScreenUpdating = False
    sChemin = ThisWorkbook.Path & "\" & "Essai"

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(sChemin) = False Then CreationDossier (sChemin)
    Set FSO = Nothing

    For Each Wsh In ThisWorkbook.Worksheets
        i = i + 1
        Wsh.ExportAsFixedFormat Type:=xlTypePDF, _
                                Filename:=sChemin & "\" & Wsh.Name, _
                                quality:=xlQualityStandard, _
                                includedocproperties:=True, _
                                ignoreprintareas:=False, _
                                from:=1, To:=1, _
                                openafterpublish:=False
        Application.StatusBar = i & " / " & ThisWorkbook.Worksheets.Count
    Next Wsh
    Application.StatusBar = "Terminé"
    Application.ScreenUpdating = True
End Sub

Private Function CreationDossier(ByVal sChemin As String) As Boolean
Dim i As Integer, sTmp As String, Ar() As String
    If InStr(sChemin, ":") = 0 Then
        Ar = Split(CurDir & "\" & sChemin, "\")
    Else
        Ar = Split(sChemin, "\")
    End If

    sTmp = Ar(0)
    ChDrive sTmp

    For i = LBound(Ar) + 1 To UBound(Ar)
        If Ar(i) <> "" Then
            sTmp = sTmp & "\" & Ar(i)
            On Error Resume Next
            MkDir sTmp
            On Error GoTo 0
        End If
    Next i

    If Dir$(sChemin, vbDirectory) = vbNullString Then
        CreationDossier = False
    Else
        CreationDossier = True
    End If
    DoEvents
End Function

 

[eric72]

Re
j'ai bien mis le code mais quand j'exécute la macro j'ai un message
"périphérique non disponible" sur ChDrive sTmp
comme je ne comprends pas bien le code je ne sais pas ce que je dois corriger!!!
Merci
Eric

 

[kiki29]

Re, et comme ici tout fonctionne, je précise je n'ai plus accès à un serveur ou un réseau quelconque ... que contient ta variable sTmp ?

 

[jcf6464]

Bonjour KIKI29, eric72 et le forum,

Chez moi tout fonctionne (excel365)

bonne continuation jcf

 

[eric72]

Re
Je me suis contenté de recopier le code

Re, et comme ici tout fonctionne, je précise je n'ai plus accès à un serveur ou un réseau quelconque ... que contient ta variable sTmp ?

Cela renvoie à une adresse sharepoint je suis sur one drive

 

[kiki29]

Re, n'ayant ni l'un ni l'autre.

 

[eric72]

Re, et comme ici tout fonctionne, je précise je n'ai plus accès à un serveur ou un réseau quelconque ... que contient ta variable sTmp ?

Re
si j'enlève le fichier de one drive cela fonctionne, maintenant j'aimerais avoir une "Application.InputBox"
qui me laisse choisir l'année pour nommer le dossier avec l'année et que les fichiers comportent dans leur nom , exemple : Stock Bx 31/03/2023 si l'année dans Application.InputBox est 2023
Je ne sais pas si je suis assez clair!!!
Oups Merci
Eric

 

[eric72]

Re, n'ayant ni l'un ni l'autre.

Re,
Grâce à vous j'ai réussi à avoir exactement ce que je voulais, je met le code au cas ou cela intéresse quelqu'un:

Option Explicit

Sub Tst()
Dim Wsh As Worksheet
Dim sChemin As String, NomDossier As String
Dim FSO As Object, i As Long

Do
NomDossier = Application.InputBox("Saisir Année d'Archive:", "Année ?", Year(Date), 1)
Loop While NomDossier = ""
If NomDossier = "" Then Exit Sub 'gestion de la touche annul

If Not IsNumeric(NomDossier) Then
MsgBox ("veuillez saisir un numerique")
NomDossier = Application.InputBox("Saisir Année d'Archive:", "Année ?", Year(Date), 1)
End If


Application.StatusBar = ""
Application.ScreenUpdating = False
sChemin = ThisWorkbook.Path & "\" & NomDossier

Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(sChemin) = False Then CreationDossier (sChemin)
Set FSO = Nothing

For Each Wsh In ThisWorkbook.Worksheets
i = i + 1
Wsh.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=sChemin & "\" & Wsh.Name, _
quality:=xlQualityStandard, _
includedocproperties:=True, _
ignoreprintareas:=False, _
from:=1, To:=1, _
openafterpublish:=False
Application.StatusBar = i & " / " & ThisWorkbook.Worksheets.Count
Next Wsh
Application.StatusBar = "Terminé"
Application.ScreenUpdating = True
End Sub

Private Function CreationDossier(ByVal sChemin As String) As Boolean
Dim i As Integer, sTmp As String, Ar() As String
If InStr(sChemin, ":") = 0 Then
Ar = Split(CurDir & "\" & sChemin, "\")
Else
Ar = Split(sChemin, "\")
End If

sTmp = Ar(0)
ChDrive sTmp

For i = LBound(Ar) + 1 To UBound(Ar)
If Ar(i) <> "" Then
sTmp = sTmp & "\" & Ar(i)
On Error Resume Next
MkDir sTmp
On Error GoTo 0
End If
Next i

If Dir$(sChemin, vbDirectory) = vbNullString Then
CreationDossier = False
Else
CreationDossier = True
End If
DoEvents
End Function

Merci beaucoup pour ce boulot, c'est top, quelle chance d'avoir accès à ce forme et à tous ces spécialistes...
Bonne soirée kIkI29 (et tous les autres) et Merci encore!!!
Eric

 

[eric72]

Re, n'ayant ni l'un ni l'autre.

Re
Et bien suis-je bête je n'ai pas réglé mon problème de chaque fichier PDF
j'ai essayé avec
dimwsh as string et
Wsh = ("Stock" & Sheet.Name & Range("q1").Value)
mais ça ne va pas, oups
Merci

 

[eric72]

Re, n'ayant ni l'un ni l'autre.

Re,
J'y suis presque avec ce code
Wsh.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=sChemin & "\" & Wsh.Name & "31/03/" & NomDossier, _
quality:=xlQualityStandard, _
includedocproperties:=True, _
ignoreprintareas:=False, _
from:=1, To:=1, _
openafterpublish:=False
Mais ça bug à l'éxecution et je ne comprends pas pourquoi...
Merci
Eric

 

[eric72]

Re
Cette fois j'ai trouvé avec ce code, pfff quel boulet!!!

Wsh.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=sChemin & "\" & Wsh.Name & " " & "Stock au 31 03" & " " & Year(Date), _
quality:=xlQualityStandard, _
includedocproperties:=True, _
ignoreprintareas:=False, _
from:=1, To:=1, _
openafterpublish:=False

 

[kiki29]

Re, un conseil, formate ton code.