(résolu par bebere et chti160)modifier ligne de code pour ajouter l'année et mois en cours

grisan29 · 15 Juillet 2017

bonjour a tous et toutes
j'ai ce code qui fonctionne très pour enregistrer le devis ou facture en .xlsm et en .pdf
dans des dossiers séparé
je voudrais lui apporter une modification afin que le code entregistre les documents mensuellement
je m'explique serait t'il possible d'enregistrer en créant le mois en cours dans un dossier au nom de l'année en cours, en fait c'est un classeur a modules de classes, voici le code qui enregistre sous et qui foncttionne

Code:

    Private Sub CB_EnregistreDansLaBase_Click()
    'procédure enregistrement sous PDF
        Dim NomFicXL As String, CheminXL As String
        Dim NomFicPDF As String, CheminPDF As String
        Dim DLig As Long
        Dim shp As Shape
        Dim Sht As Worksheet

        Set Sht = ThisWorkbook.Sheets(WS_FACTURE)
        Sht.Range("I17") = Sht.Range("I17").Value
        If Sht.Range("IS_DOC_SAVED_IN_BASE") Then
            UpdateTitre Sht.Range("DOC_TYPE")
        End If
        Sht.Range("IS_DOC_SAVED_IN_BASE") = True

        DLig = Sht.Range("C" & Rows.Count).End(xlUp).Row
        Dim NomDeFichier As String
        NomDeFichier = Sht.Range("DOC_TITRE").Value & " - " & Sht.Range("DOC_CLIENT").Value
        NomFicXL = NomDeFichier & ".xlsm"
        NomFicPDF = NomDeFichier & ".pdf"
        ' Pour vérification de la valeur
        Select Case UCase(Sht.Range("DOC_TYPE").Value)
        Case DOC_DEVIS: CheminXL = DIR_DEVIS
        Case DOC_FACT: CheminXL = DIR_FACT
        Case DOC_FACT_AQUI: CheminXL = DIR_FACT_AQUI
        Case DOC_FACT_ACC: CheminXL = DIR_FACT_ACC
        Case Else
            MsgBox "Erreur pour trouver le chemin de " & Sht.Range("D1").Value
            Exit Sub
        End Select

        CheminPDF = CheminXL & "PDF\"
        CheminXL = CheminXL & "\"

        ' Sauvegarder le classeur actif dans le chemin et le nom determiné
        ' FileFormat:=xlExcel8,
        ActiveWorkbook.SaveAs Filename:=DIR_WORKSPACE & CheminXL & NomFicXL, _
                              Password:="", WriteResPassword:="", _
                              ReadOnlyRecommended:=False, CreateBackup:=False

        'SetButtonsVisible True
        '**********************************************************************************
        With Sht
            .Activate
            'code a tester et a supprimer si encore probleme
            With .PageSetup
                DLig = Range("suivant").Row
                'MsgBox DerLig
                .PrintArea = "C1:M" & DLig  'Sh.UsedRange.Rows.Count
                '.PrintArea = ""
                'la plage de cellules à imprimer pour chaque page
                .PrintTitleRows = Sht.Range("C17:M18").Address
                '.FitToPagesTall = 1
                .FitToPagesWide = 1
                .Orientation = xlPortrait
                .PrintHeadings = False
                ' "pied de page au centre"
                .CenterFooter = "&16&""Arial,Gras""SIRET : 123456789   -   NAF : 0123p  -   RCS : 00000 -   N° TVA   :  FR00123456789" & Chr(10) & _
                                "assurance décennale n°123456789 de chez untel"

            End With
        End With
        '**********************************************************************************

        ' Exporter en PDF
        ActiveWorkbook.ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=DIR_WORKSPACE & CheminPDF & NomFicPDF, Quality:= _
                                                       xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
                                                       OpenAfterPublish:=False

        SetButtonsVisible True
        envoifacnue
        MsgBox "Votre sauvegarde porte la référence : " & " " & NomFicXL & vbCrLf _
             & "Le fichier PDF à été créé sous le nom : " & NomFicPDF

        ' Fermer le classeur actif
        'ActiveWorkbook.Close

        'Sauvegarde les modifications
        AjouteDocDansLaBase
end sub

voici le code public du module de répérage du nom de feuille

Code:

Public Const DIR_WORKSPACE As String = "C:\Facturation"
Public Const DIR_DEVIS As String = "\Devis"
Public Const DIR_FACT As String = "\Facture"
Public Const DIR_FACT_AQUI As String = "\Factureacquittee"
Public Const DIR_FACT_ACC As String = "\Factureacompte"

j'ai ce code qui le fait mais je n'arrive pas a l'adapter

Code:

' Exporter en PDF
Public Sub Export_PDF()

    Dim F As Worksheet
    Dim Chemin As String
    Dim Client As String
    Dim Sh As Shape
    Dim mois As String, annee As String
        annee = "\" & Year(Date)
         mois = MonthName(Month(Date)) & "\"
      
    Application.DisplayAlerts = False
 
    Set F = ThisWorkbook.Sheets(WS_FACTURE)

    Chemin = "C:\Facturation\Facture seule\devispdf" & annee & mois
    If Dir(Chemin, vbDirectory) = "" Then
        MkDir Chemin
    End If
    Select Case F.Range("DOC_TYPE")
    Case DOC_DEVIS

        Chemin = "C:\Facturation\Facture seule\devispdf" & annee & mois
        If Dir(Chemin, vbDirectory) = "" Then
            MkDir Chemin
        End If
    Case DOC_FACT_ACC
        Chemin = "C:\Facturation\Facture seule\facture acomptepdf" & annee & mois
        If Dir(Chemin, vbDirectory) = "" Then
            MkDir Chemin
        End If
    Case DOC_FACT_AQUI
        Chemin = "C:\Facturation\Facture seule\facture acquitteepdf" & annee & mois
        If Dir(Chemin, vbDirectory) = "" Then
            MkDir Chemin
        End If
    Case DOC_FACT
        Chemin = "C:\Facturation\Facture seule\facturepdf" & annee & mois
        If Dir(Chemin, vbDirectory) = "" Then
            MkDir Chemin
        End If
    Case Else
        MsgBox "Impossibilité de déterminer le chemin" & vbCr & "Fin du programme"
        End
    End Select

    Client = F.Range("DOC_TITRE") & " - " & F.Range("DOC_CLIENT")

    Application.ScreenUpdating = False

    'code qui enregistre en .pdf

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Chemin & Client, Quality:=xlQualityStandard, _
                                    IncludeDocProperties:=True, IgnorePrintAreas:=False, _
                                    From:=1, To:=1, OpenAfterPublish:=False

MsgBox "Le fichier PDF à été créé sous le nom : " & " " & Client '& vbCrLf _
         & "Le fichier PDF à été créé sous le nom : " & NomFicPDF

End Sub

merci d'avance

Lone-wolf · 15 Juillet 2017

Bonsoir Pascal , le Forum

Pourquoi dans le 2ème code tu as des doublons (chemin et conditions) ?? Ensuite, tu as année - mois et client; puis le MsgBox NomFicPDF?? . C'est incompréhensible.

Sheets("WS_FACTURE").Activate
Chemin = "C:\Facturation\Facture seule\devispdf"

annee = Year(Date)
mois = Format(Month(Date), "mmmm")
Activesheet.SaveAs chemin & annee & mois

grisan29 · 15 Juillet 2017

Bonsoir Lone-wolf
merci de ta réponse
d'accord c'est le code d'essai que j'ai mis avec mes excuses

Code:

Public Sub Export_PDF()
  
    Dim F As Worksheet
    Dim Chemin As String
    Dim Client As String
    Dim Sh As Shape
    Dim mois As String, annee As String
        annee = "\" & Year(Date)
         mois = MonthName(Month(Date)) & "\"
        
    Application.DisplayAlerts = False
   
    Set F = ThisWorkbook.Sheets(WS_FACTURE)

    Select Case F.Range("DOC_TYPE")
    Case DOC_DEVIS
        Chemin = "C:\Facturation\Facture seule\devispdf" & annee & mois
        If Dir(Chemin, vbDirectory) = "" Then
            MkDir Chemin
        End If
    Case DOC_FACT_ACC
        Chemin = "C:\Facturation\Facture seule\facture acomptepdf" & annee & mois
        If Dir(Chemin, vbDirectory) = "" Then
            MkDir Chemin
        End If
    Case DOC_FACT_AQUI
        Chemin = "C:\Facturation\Facture seule\facture acquitteepdf" & annee & mois
        If Dir(Chemin, vbDirectory) = "" Then
            MkDir Chemin
        End If
    Case DOC_FACT
        Chemin = "C:\Facturation\Facture seule\facturepdf" & annee & mois
        If Dir(Chemin, vbDirectory) = "" Then
            MkDir Chemin
        End If
    Case Else
        MsgBox "Impossibilité de déterminer le chemin" & vbCr & "Fin du programme"
        End
    End Select

    Client = F.Range("DOC_TITRE") & " - " & F.Range("DOC_CLIENT")

    Application.ScreenUpdating = False

    'code qui enregistre en .pdf

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Chemin & Client, Quality:=xlQualityStandard, _
                                    IncludeDocProperties:=True, IgnorePrintAreas:=False, _
                                    From:=1, To:=1, OpenAfterPublish:=False

MsgBox "Le fichier PDF à été créé sous le nom : " & " " & Client


End Sub

Bebere · 17 Juillet 2017

bonjour
Grisan comme suit,si bien compris

grisan29 à dit:
Chemin = "C:\Facturation\Facture seule\devispdf\" & format(Date,"mmmmyyyy") & "\"

grisan29 · 17 Juillet 2017

Bonjour bebere
merci de ta réponse que je confirme donc

Code:

Chemin = "C:\Facturation\Facture seule\devispdf\" & format(Date,"mmmmyyyy") & "\"

est le 2ème code qui fonctionne bien il créer l'année si elle n'existe pas et dedans il créer le mois en cours
D:\Facturation-v1s\factureseule\devis\2017\juillet (par exemple pour le devis)

et tant que le mois n'est pas fini les documents vont dedans et dès que le changement de mois se fait un autre dossier est créer dans l'année
et j'essaie d'adapter ce code au 1er pour qu'il me fasse pareil
pour l'instant je m'en contentait mais j'ai changer de comptable qui est plus exigeant

Bebere · 17 Juillet 2017

Grisan
ce n'est pas aussi simple que tu le penses
à mon avis il faut créer une fonction
je vais essayer

Bebere · 17 Juillet 2017

Grisan tester en partie,la suite pour toi

Code:

Public Sub Export_PDF()

    Dim F As Worksheet, x As String
    Dim Chemin As String
    Dim Client As String
    Dim Sh As Shape
    Dim Mois As String, Annee As String
    '    Annee = "\" & Year(Date)
    '    Mois = MonthName(Month(Date)) & "\"

    Application.DisplayAlerts = False
    Chemin = "D:\Facturation-v1s\factureseule\"
    Set F = ThisWorkbook.Sheets(WS_FACTURE)

    Select Case F.Range("DOC_TYPE")
    Case DOC_DEVIS
        x = "DOC_DEVIS"

    Case DOC_FACT_ACC
        x = "DOC_FACT_ACC\"

    Case DOC_FACT_AQUI
        x = "DOC_FACT_AQUI\"

    Case DOC_FACT
        x = "DOC_FACT\"

    Case Else
        MsgBox "Impossibilité de déterminer le chemin" & vbCr & "Fin du programme"
        End
    End Select

    Chemin = Chemin & x & Format(Date, "yyyy") & "\" & Format(Month(Date), "mmmm")
    CreateFolders Chemin

    Client = "\" & F.Range("DOC_TITRE") & " - " & F.Range("DOC_CLIENT")
    Chemin = Chemin & Client
    CreateFolders Chemin
   
    Application.ScreenUpdating = False

    'code qui enregistre en .pdfD:\Facturation-v1s\factureseule\devis\2017\juillet (par exemple pour le devis)

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Chemin, Quality:=xlQualityStandard, _
                                    IncludeDocProperties:=True, IgnorePrintAreas:=False, _
                                    From:=1, to:=1, OpenAfterPublish:=False

    MsgBox "Le fichier PDF à été créé sous le nom : " & " " & Client


End Sub

Code:

Sub CreateFolders(ByVal strPath As String)
    Dim varFolders() As String
    Dim varFolder As Long
    Dim strTemp As String

    On Error GoTo CreateFoldersErr
    varFolders = Split(strPath, "\")
    strTemp = ""

    For varFolder = LBound(varFolders) To UBound(varFolders)
        If varFolders(varFolder) <> "" Then
            If strTemp <> "" Then strTemp = strTemp & "\"
            strTemp = strTemp & varFolders(varFolder)

            CreateFolder strTemp    'appel de CreateFolder
        End If
    Next
    Exit Sub

CreateFoldersErr:
    MsgBox Err.Description, vbExclamation
    Exit Sub
End Sub

Sub CreateFolder(ByVal strDossier As String)
    If Dir(strDossier, vbDirectory) = "" Then
        MkDir strDossier
    End If
End Sub

ChTi160 · 17 Juillet 2017

Bonsoir le Fil,Le Forum
je regarde avec beaucoup d'attention ce fil
et je crois qu'il y a une petite erreur dans cette ligne de code :

VB:

Chemin = Chemin & x & Format(Date, "yyyy") & "\" & Format(Month(Date), "mmmm")

Month(Date) renvoie je pense un Chiffre donc pas évident de le formater en Un mois genre "Janvier"
donc il faudrait mettre je pense :

VB:

Format(Date, "mmmm")

En espérant avoir pu faire avancer la Chose(sauf erreur de ma part) Lol
Bonne fin de Journée
Amicalement
Jean marie

grisan29 · 17 Juillet 2017

Bonjour Bèbère, chti160 et le forum
ce n'est pas le code "export.pdf que je demande de modifier, mais celui plus compliquer de
Private Sub CB_EnregistreDansLaBase_Click()
qui est le 1er code mis en haut
mais je vais quand même le tester on ne sais jamais car tu es plus performant
comment je déclare le x dans cet exemple
Case DOC_DEVIS
x = "DOC_DEVIS"
en fait j'ai créer 2 codes un qui exporte en Pdf et l'autre en .xlsx pour enregitrer sans codes ni boutons car je n'ai pas réussi en 1 seul
chti160 je vais également tester ce que tu dit mais le code sauve en créant un dossier "année" ex 2017 et dedans il créer un sous-dossier avec le mois en cours

en fait mon nouveau comptable m'as demander un dossier pour chaque document .pdf où .xlsx
et je voudrais améliorer en le faisant au 1er code
voici ou je range tous mes documents sous d:

ainsi que dans le dossier "facture seule"

et enfin la sauvegarde dans les dossiers

mais la sauvegarde ne doit pas se faire 2017-07 2017-08 etc

grisan29 · 17 Juillet 2017

bonsoir bèbère
j'ai fait un test la sauverde .pdf se fait sans bug mais pas comme il faut

grisan29 · 17 Juillet 2017

bonsoir bèbère
j'ai enlever X dans le chemin et c'est mieux mais dans ce cas x = "DOC_DEVIS" ne sert plus ?

Code:

Chemin = Chemin & Format(Date, "yyyy") & "\" & Format(Month(Date), "mmmm")

mais pourquoi un dossier en plus au dessus du .pdf comme dans l'image du précédent post

Bebere · 17 Juillet 2017

Grisan
toi tu as les dossiers et sous dossiers,moi pas
donne de bons exemples et j'adapterai,supposition(x est il mal positionné
client est le nom du fichier et x doit se mettre avec)
bonjour Chti déjà essayer ta proposition

grisan29 · 17 Juillet 2017

bonsoir Bèbère
je n'ai que les dossiers, les sous dossier année et mois sont créer par le code
dans le sous dossiers année (2017) vient le mois( juillet) et dans le mois viens l'enregistrement sous le nom écrit comme l’aperçu mis plus haut nommé "code bebere" mais sans le dossier au nom identique
X tel qu'il est non, avant c'était

Code:

 Case DOC_DEVIS

        Chemin = "C:\Facturation\Facture seule\devispdf" & annee & mois
        If Dir(Chemin, vbDirectory) = "" Then
            MkDir Chemin
        End If

Bebere · 18 Juillet 2017

bonjour
Grisan
regarde ce code et dis moi si c'est bon
plus bas en dessous de résultat(commentaire), ce qui est obtenu
d'après ce que j'ai compris c'est bon
pour CB_EnregistreDansLaBase_Click ce serait plus facile d'avoir un classeur
avec l'essentiel pour pouvoir tester le code

Code:

Public Sub Export_PDF()

    Dim F As Worksheet, x As String
    Dim Chemin As String
    Dim Client As String
    Dim Sh As Shape
    Dim Mois As String, Annee As String
    '    Annee = "\" & Year(Date)
    '    Mois = MonthName(Month(Date)) & "\"

    Application.DisplayAlerts = False
    Chemin = "D:\Facturation-v1s\factureseule\"
'    Set F = ThisWorkbook.Sheets(WS_FACTURE)
"içi mis DOC_DEVIS
    Select Case "DOC_DEVIS" 'F.Range("DOC_TYPE")
    Case "DOC_DEVIS"
        x = "devispdf\"

    Case "DOC_FACT_ACC"
        x = "facture acomptepdf>"

    Case "DOC_FACT_AQUI"
        x = "facture acquitteepdf\"

    Case "DOC_FACT"
        x = "facturepdf\"

    Case Else
        MsgBox "Impossibilité de déterminer le chemin" & vbCr & "Fin du programme"
        End
    End Select

    Chemin = Chemin & x & Format(Date, "yyyy") & "\" & Format(Date, "mmmm")
    CreateFolders Chemin
'*************
'résultat =D:\Facturation-v1s\factureseule\devispdf\2017\janvier
'*************
''    Client = "\" & F.Range("DOC_TITRE") & " - " & F.Range("DOC_CLIENT")
'    Chemin = Chemin & Client
'    CreateFolders Chemin
  
    Application.ScreenUpdating = False

    'code qui enregistre en .pdfD:\Facturation-v1s\factureseule\devis\2017\juillet (par exemple pour le devis)

'    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Chemin, Quality:=xlQualityStandard, _
'                                    IncludeDocProperties:=True, IgnorePrintAreas:=False, _
'                                    From:=1, to:=1, OpenAfterPublish:=False
'
'    MsgBox "Le fichier PDF à été créé sous le nom : " & " " & Client


End Sub

ChTi160 · 18 Juillet 2017

Bonjour Grisan
Bonjour Le fil (Bebere) ,Le Forum
je viens de tester
pour définir ce que renvoie

Chemin = Chemin & x & Format(Date, "yyyy") & "\" & Format(Month(Date), "mmmm")

VB:

Sub test()
MsgBox Format(Month(Date), "mmmm") & vbCrLf & Format(Date, "mmmm")
End Sub

Et J'obtiens Janvier pour Format(Month(Date), "mmmm") et Juillet pour Format(Date, "mmmm")
Cela a t'il une importance , Janvier au Lieu du Mois en Cours Juillet Lol
je pense que Oui !
Bonne journée
Amicalement
Jean marie

(résolu par bebere et chti160)modifier ligne de code pour ajouter l'année et mois en cours

grisan29

XLDnaute Accro

Lone-wolf

XLDnaute Barbatruc

grisan29

XLDnaute Accro

Bebere

XLDnaute Barbatruc

grisan29

XLDnaute Accro

Bebere

XLDnaute Barbatruc

Bebere

XLDnaute Barbatruc

ChTi160

XLDnaute Barbatruc

grisan29

XLDnaute Accro

grisan29

XLDnaute Accro

Pièces jointes

grisan29

XLDnaute Accro

Bebere

XLDnaute Barbatruc

grisan29

XLDnaute Accro

Bebere

XLDnaute Barbatruc

ChTi160

XLDnaute Barbatruc

Discussions similaires