Microsoft 365 Vba Impression PDF

eric72

XLDnaute Accro
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
 

Pièces jointes

  • test.xlsm
    50.4 KB · Affichages: 12

kiki29

XLDnaute Barbatruc
Re, un début, à toi de poursuivre.
VB:
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
 
Dernière édition:

eric72

XLDnaute Accro
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

XLDnaute Accro
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

XLDnaute Accro
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

XLDnaute Accro
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
 

Discussions similaires

Réponses
22
Affichages
1 K

Statistiques des forums

Discussions
311 725
Messages
2 081 941
Membres
101 846
dernier inscrit
Silhabib