XL 2019 Aide pour un module d'archivage de feuille en pdf dans répertoire

Nico2978 · 5 Avril 2024

Bonjour à tous,
C'est mon premier message sur le forum, je me présente brièvement. Nicolas, chargé de projets dans une laiterie, je mets un peu mon nez dans le VBA pour pouvoir automatiser certaines tâches sur excel et accompagner mon entreprise vers une "digitalisation", car beaucoup de données actuellement enregistré sur support papier.

Dans la même veine ce chantier comprend:

Une interface de saisie pour le remplissage et l'archivage de feuilles de non-conformités qualité
Une interface de création de bon de commande reliée à une base de données fournisseur & articles

Je poste ce topic afin de vous demander de l'aide svp dans le cadre d'un projet de création d'une application de gestion de données de production d'une laiterie.
Je suis assez novice en VBA et cherche à saisir des automatismes en dev

Le topic concerne une partie du projet qui est l'archivage de feuille de production journalière en pdf dans un dossier "yyyy" avec un nom de doc "ddmmyyy".

Une partie du code fonctionne, à savoir la création de dossier et l'export de fichier avec le nom souhaité. Le problème se pose au niveau des conditions pour l'archivage.

Je souhaiterais en effet procéder comme suit après pression d'un bouton "exporter

1) Vérifier l'existence du répertoire

Si FAUX
1. Créer un répertoire format yyyy et y exporter le fichier
Si VRAI--> vérifier l'existence du fichier dans le répertoire
1. Si FAUX -->Exporter le fichier du jour
2. Si VRAI--> Demander la validation pour écraser le fichier existant
  1. Si non --> Quitter le programme
  2. Si oui--> Supprimer le ficher le fichier existant + Exporter le nouveau fichier

Je rencontre 2 problèmes:

1) Mon premier ElseIf ne prend pas en compte l'existence d'un fichier du même et en recrée un dans tous les cas

Je pensais avoir bien compris l'intérêt de l'association des fonctions len(dir( qui renvoie le chemin en chaine puis énumère le nombre de caractère de la chaine; et si pas de chaine =Néant. Mais vu le résultat j'en doute

2) J'ai du mal à gérer la msg box yes/no au niveau de la synthaxe, je me suis surement planté quelque part

Voici le code:

VB:

Sub Archivage()
Application.ScreenUpdating = False

'Definition des variables de la feuille
Dim Prod1 As Date
Dim Prod2 As String
Dim Annee As String

Prod1 = Sheets("production").Cells(1, 2)
Prod2 = Format(Sheets("production").Cells(1, 2), "ddmmyyyy")
Annee = Year(Prod1)

'Boucle de recherche dossier
Dim x As String
Dim chemin As String
Dim Fichier As String
chemin = "Y:\LAITERIE\2-PRODUCTION\1-Productions\" & Annee
Fichier = chemin & "\" & Prod2

On Error Resume Next

x = GetAttr(chemin) And 0
If Err <> 0 Then 'créer le dossier et le fichier prod
MkDir chemin
        Sheets("Production").ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=chemin & "\" & Prod2, _
        Quality:=xlQualityMinimum, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=True

ElseIf Len(Dir(Fichier)) = 0 Then 'crée le fichier prod s'il n'existe pas
        Sheets("Production").ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=chemin & "\" & Prod2, _
        Quality:=xlQualityMinimum, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=True

ElseIf Len(Dir(Fichier)) > 0 Then 'contrôle box pour la décision d'écraser fiche existante ou abandon
MsgBox = vbYesNo("Voulez vous écraser la fiche de production?", "Fiche de production déjà existante")
casevbyes
Kill (chemin & "\" & Prod2)
 Sheets("Production").ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=chemin & "\" & Prod2, _
        Quality:=xlQualityMinimum, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=True
casevbno
Exit Sub

End If

Application.ScreenUpdating = True

End Sub

Pour pouvoir tester le code, il faut simplement avoir une date en B1

J'espère avoir été bien clair et je reste dispo pour apporter des éclaircissements en cas de besoin.

Merci d'avance pour l'aide que vous pourrez m'apporter

Bonne journée à tous

Franc58 · 5 Avril 2024

Salut, j'ai un peu modifié ta macro. Pour ta variable Fichier il faut ajouter l'extension .pdf.
L'utilisation de MsgBox n'est pas correcte. Vois ci-dessous.

VB:

Sub Archivage()
    Application.ScreenUpdating = False

    'Definition des variables de la feuille
    Dim Prod1 As Date
    Dim Prod2 As String
    Dim Annee As String

    Prod1 = Sheets("production").Cells(1, 2)
    Prod2 = Format(Sheets("production").Cells(1, 2), "ddmmyyyy")
    Annee = Year(Prod1)

    'Boucle de recherche dossier
    Dim x As String
    Dim chemin As String
    Dim Fichier As String
    chemin = "Y:\LAITERIE\2-PRODUCTION\1-Productions\" & Annee
    Fichier = chemin & "\" & Prod2 & ".pdf"

    On Error Resume Next

    x = GetAttr(chemin) And 0
    If Err...

Nico2978 · 5 Avril 2024

J'en viens à me poser la question de la faisabilité de ce programme

Franc58 · 5 Avril 2024

Salut, j'ai un peu modifié ta macro. Pour ta variable Fichier il faut ajouter l'extension .pdf.
L'utilisation de MsgBox n'est pas correcte. Vois ci-dessous.

VB:

Sub Archivage()
    Application.ScreenUpdating = False

    'Definition des variables de la feuille
    Dim Prod1 As Date
    Dim Prod2 As String
    Dim Annee As String

    Prod1 = Sheets("production").Cells(1, 2)
    Prod2 = Format(Sheets("production").Cells(1, 2), "ddmmyyyy")
    Annee = Year(Prod1)

    'Boucle de recherche dossier
    Dim x As String
    Dim chemin As String
    Dim Fichier As String
    chemin = "Y:\LAITERIE\2-PRODUCTION\1-Productions\" & Annee
    Fichier = chemin & "\" & Prod2 & ".pdf"

    On Error Resume Next

    x = GetAttr(chemin) And 0
    If Err <> 0 Then 'créer le dossier et le fichier prod
        MkDir chemin
        Sheets("Production").ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=Fichier, _
        Quality:=xlQualityMinimum, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=True

    ElseIf Len(Dir(Fichier)) = 0 Then 'crée le fichier prod s'il n'existe pas
        Sheets("Production").ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=Fichier, _
        Quality:=xlQualityMinimum, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=True

    ElseIf Len(Dir(Fichier)) > 0 Then 'contrôle box pour la décision d'écraser fiche existante ou abandon
        Dim response As VbMsgBoxResult
        response = MsgBox("Voulez vous écraser la fiche de production?", vbYesNo, "Fiche de production déjà existante")

        If response = vbYes Then
            ' Supprimer le fichier existant et exporter le nouveau fichier
            Kill Fichier
            Sheets("Production").ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=Fichier, _
            Quality:=xlQualityMinimum, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=True
        Else
            ' Quitter le programme
            Exit Sub
        End If
    End If

    Application.ScreenUpdating = True
End Sub

Phil69970 · 5 Avril 2024

Bonjour @Nico2978 et bienvenu sur XLD
Edit :Bonjour Franck

J'ai pas vu ton fichier.....

Nico2978 · 5 Avril 2024

Phil69970 à dit:
Bonjour @Nico2978 et bienvenu sur XLD
Edit :Bonjour Franck

J'ai pas vu ton fichier.....

Bonjour Phil , merci!
Oui en effet je ne l'ai consciemment pas posté comme le module peut fonctionner juste avec un onglet intitulé production et une case au format date. Prochaine fois je poste tout !

Bon weekend

Nico2978 · 5 Avril 2024

Franc58 à dit:

Salut, j'ai un peu modifié ta macro. Pour ta variable Fichier il faut ajouter l'extension .pdf.
L'utilisation de MsgBox n'est pas correcte. Vois ci-dessous.

VB:

Sub Archivage()
    Application.ScreenUpdating = False

    'Definition des variables de la feuille
    Dim Prod1 As Date
    Dim Prod2 As String
    Dim Annee As String

    Prod1 = Sheets("production").Cells(1, 2)
    Prod2 = Format(Sheets("production").Cells(1, 2), "ddmmyyyy")
    Annee = Year(Prod1)

    'Boucle de recherche dossier
    Dim x As String
    Dim chemin As String
    Dim Fichier As String
    chemin = "Y:\LAITERIE\2-PRODUCTION\1-Productions\" & Annee
    Fichier = chemin & "\" & Prod2 & ".pdf"

    On Error Resume Next

    x = GetAttr(chemin) And 0
    If Err <> 0 Then 'créer le dossier et le fichier prod
        MkDir chemin
        Sheets("Production").ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=Fichier, _
        Quality:=xlQualityMinimum, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=True

    ElseIf Len(Dir(Fichier)) = 0 Then 'crée le fichier prod s'il n'existe pas
        Sheets("Production").ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=Fichier, _
        Quality:=xlQualityMinimum, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=True

    ElseIf Len(Dir(Fichier)) > 0 Then 'contrôle box pour la décision d'écraser fiche existante ou abandon
        Dim response As VbMsgBoxResult
        response = MsgBox("Voulez vous écraser la fiche de production?", vbYesNo, "Fiche de production déjà existante")

        If response = vbYes Then
            ' Supprimer le fichier existant et exporter le nouveau fichier
            Kill Fichier
            Sheets("Production").ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=Fichier, _
            Quality:=xlQualityMinimum, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=True
        Else
            ' Quitter le programme
            Exit Sub
        End If
    End If

    Application.ScreenUpdating = True
End Sub

Bonjour Franck, merci mille fois pour ton aide qui résout complétement mon problème!
J'ai appris au passage qu'il faut nommer et dimensionner la variable correspondant à la msgbox yes/no, super

Bon weekend

XL 2019 Aide pour un module d'archivage de feuille en pdf dans répertoire

Nico2978

XLDnaute Nouveau

Franc58

Nico2978

XLDnaute Nouveau

Franc58

XLDnaute Occasionnel

Phil69970

XLDnaute Barbatruc

Nico2978

XLDnaute Nouveau

Nico2978

XLDnaute Nouveau

Discussions similaires