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

[grisan29]

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

    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

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

' 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

 

[grisan29]

bonjour chti160
je ne peux mettre mois et années car ils mis en commentaire depuis le code de bebere

 

[Bebere]

bonjour Grisan Jean Marie
Je n'ai traité que le code que j'ai mis
et içi les fichiers vont aux bons endroits
le fichier que tu as contient il
CreateFolders içi dans module mgestion
regarde si ils sont dans ton fichier la sub doit être PUBLIC si dans un autre module
pas beaucoup de temps pour le moment je regarderai le week end
si tu as une priorité dis le
rmq concentre toi sur un code met le au point.Je trouve que tu te disperces en pure perte
ce n'est pas difficile les dossiers chaque\ en est un
C:\
facture-v1s\
FactureSeul\
Devis\
année\
mois\
le fichier
Il faut faire attention à la casse dans les traitements
pour la lettre lecteur il est recommandé de rester en majuscule

 

[ChTi160]

Bonsoir Grisan
Bonsoir Bebere ,Le Forum
Grisan , il faudrait que tu mettes un exemple de ce que doivent être le chemin et autres Noms de Dossier ,s/D0ssier :
Ex C:\facture-v1s\FactureSeul\Devis\année\mois , puis le Format du Nom du fichier
pour le xlsx et le Pdf
je pense , que comme le dit Bebere ,,tu dois déjà avoir tout ce qu'il te faut ,reste à le mettre en Forme Lol
Merci par avance
Amicalement
Jean marie

 

[grisan29]

bonsoir a vous
le lieu de sauvegarde est en apercu dans le post 24 sous le code
C:\Facturation\Facture seule\devis
C:\Facturation\Facture seule\devispdf
C:\Facturation\Facture seule\facture acompte
C:\Facturation\Facture seule\facture acomptepdf
C:\Facturation\Facture seule\facture acquittee
C:\Facturation\Facture seule\facture acquitteepdf
C:\Facturation\Facture seule\facturepdf
C:\Facturation\Facture seule\factures
et c'est derrière chaque fin de ligne le lieu de stockage donc avec un \ derrière

Bebere
CreateFolders içi dans module mgestion
oui il est dans le module de gestions comme les autres codes qui sont en cours de modif dans ce post

 

[Bebere]

Grisan
Un autre qui va bien

Public Sub envoifacture()    'sans les boutons et codes
    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 = "D:\Facturation\Facture seule\"    'changé C en D
    Select Case F.Range("DOC_TYPE")
    Case DOC_DEVIS
        Chemin = Chemin & "devis\" & Annee & "\" & Mois & "\"
    Case DOC_FACT_ACC
        Chemin = Chemin & "facture acompte\" & Annee & "\" & Mois & "\"  '"C:\Facturation\Facture seule\facture acompte\" & Annee & Mois
        '        If Dir(Chemin, vbDirectory) = "" Then
        '            MkDir Chemin
        '        End If
    Case DOC_FACT_AQUI
        Chemin = Chemin & "facture acquittee\" & Annee & "\" & Mois & "\"
        '        If Dir(Chemin, vbDirectory) = "" Then
        '            MkDir Chemin
        '        End If
    Case DOC_FACT
        Chemin = Chemin & "factures\" & 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

    CreateFolders Chemin

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

    Application.ScreenUpdating = False

    F.Copy
    With ActiveWorkbook
        With .Sheets(1)
            For Each Sh In .Shapes
                If Sh.Type <> msoPicture Then
                    Sh.Delete
                End If
            Next Sh
            F.Cells(3, 1) = F.Cells(3, 1).Value
            .Cells.Copy
            .Range("A1").PasteSpecial Paste:=xlPasteValues
            .Range("A1").Select
        End With
        Application.DisplayAlerts = False  ' Si fichier identique présent : l'écrase sans alerte
        .SaveAs Filename:=Chemin & Client & ".xlsx"
        .Close
    End With
    MsgBox "Votre sauvegarde porte la référence : " & " " & Client    '& vbCrLf _
                                                                      & "Le fichier PDF à été créé sous le nom : " & NomFicPDF
    Application.DisplayAlerts = True
    Export_PDF
End Sub

ps:réveillé par le téléphone,dans certains cas invention du diable
je me suis calmé sur du code(lol comme dirait Jean Marie et comme il aime les chtis Z'ean Mari devrait lui plair Re LOL)

 

[grisan29]

bonjour Bebere
ton réveil a bien fonctionner car le résultat est a la hauteur de ce que j'essayai de faire
je n'étais pas loin, il me manquais le getfolder
MERCI a toi et a chti160

 

[grisan29]

bonjour Bebere, chti160
bebere peut me mettre des commentaires pour que je comprenne le code de création des dossiers

'créations des dossiers
Sub CreateFolders(ByVal strPath As String)
'déclaration des variables
    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

 

[Bebere]

bonjour
Grisan avant tu mets un point d'arrêt sur une ligne exécutable de CreateFolders

'menu Affichage,choisir fenêtre variables locales
'exécute le code pas à pas touche F8 et tu verras le contenu de varfolders etc
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, "\") 'crée un tableau avec les dossiers
    strTemp = ""

    For varFolder = LBound(varFolders) To UBound(varFolders) 'parcourre le tableau
        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 'crée le dossier
    End If
End Sub

 

[grisan29]

Bonsoir Bebere
je ne connaissait pas cette manipulation
restera a voir si le changement de mois sera bien dans une dizaine de jours

 

[ChTi160]

Bonjour Grisan29
Bonjour le Fil (Bebere) ,Le Forum
Pour tester (tu crees un fichier test) puis tu ajoutes des Jours à la variable Mois exemple

Mois = MonthName(Month(Date+10)) ou Mois =Format(date+10,"mmmm")

Devrait correspondre au mois prochain Lol
Bonnne fin de journée
Amicalement
Jean marie

 

[grisan29]

bonjour Jean Marie
Merci de ta réponse je n'y avais pas penser mais ca marche le mois d'août a été créer et dadans est aller le devis comme il faut
un GRAND merci a vous 2
Pascal