1. Ce site utilise des "témoins de connexion" (cookies) conformes aux textes de l'Union Européenne. Continuer à naviguer sur nos pages vaut acceptation de notre règlement en la matière. En savoir plus.

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

Discussion dans 'Forum Excel' démarrée par grisan29, 15 Juillet 2017.

  1. grisan29

    grisan29 XLDnaute Accro

    Inscrit depuis le :
    26 Mai 2008
    Messages :
    1745
    "J'aime" reçus :
    38
    Sexe :
    Masculin
    Habite à:
    plouescat (29N)
    Utilise:
    Excel 2013 (PC)
    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 (Text):
        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 (Text):
    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 (Text):
    ' 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
     
  2. Lone-wolf

    Lone-wolf XLDnaute Barbatruc

    Inscrit depuis le :
    25 Mars 2010
    Messages :
    5159
    "J'aime" reçus :
    351
    Sexe :
    Masculin
    Travail/Loisirs :
    SE/Programmation (VBA Excel)
    Habite à:
    Ouest-Suisse
    Page d'accueil :
    Utilise:
    Excel 2013 (PC)
    Bonsoir Pascal :), le Forum :)

    Pourquoi dans le 2ème code tu as des doublons (chemin et conditions) ?? :rolleyes: Ensuite, tu as année - mois et client; puis le MsgBox NomFicPDF?? :rolleyes:. 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
     
  3. grisan29

    grisan29 XLDnaute Accro

    Inscrit depuis le :
    26 Mai 2008
    Messages :
    1745
    "J'aime" reçus :
    38
    Sexe :
    Masculin
    Habite à:
    plouescat (29N)
    Utilise:
    Excel 2013 (PC)
    Bonsoir Lone-wolf
    merci de ta réponse
    d'accord c'est le code d'essai que j'ai mis avec mes excuses
    Code (Text):
    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
     
     
  4. Bebere

    Bebere XLDnaute Barbatruc

    Inscrit depuis le :
    8 Mai 2005
    Messages :
    5747
    "J'aime" reçus :
    70
    Habite à:
    Tongres
    Utilise:
    Excel 2003 (PC)
    bonjour
    Grisan comme suit,si bien compris
     
  5. grisan29

    grisan29 XLDnaute Accro

    Inscrit depuis le :
    26 Mai 2008
    Messages :
    1745
    "J'aime" reçus :
    38
    Sexe :
    Masculin
    Habite à:
    plouescat (29N)
    Utilise:
    Excel 2013 (PC)
    Bonjour bebere
    merci de ta réponse que je confirme donc
    Code (Text):
    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
     
  6. Bebere

    Bebere XLDnaute Barbatruc

    Inscrit depuis le :
    8 Mai 2005
    Messages :
    5747
    "J'aime" reçus :
    70
    Habite à:
    Tongres
    Utilise:
    Excel 2003 (PC)
    Grisan
    ce n'est pas aussi simple que tu le penses
    à mon avis il faut créer une fonction
    je vais essayer
     
  7. Bebere

    Bebere XLDnaute Barbatruc

    Inscrit depuis le :
    8 Mai 2005
    Messages :
    5747
    "J'aime" reçus :
    70
    Habite à:
    Tongres
    Utilise:
    Excel 2003 (PC)
    Grisan tester en partie,la suite pour toi
    Code (Text):
    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 (Text):
    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
     
     
  8. ChTi160

    ChTi160 XLDnaute Barbatruc

    Inscrit depuis le :
    20 Février 2005
    Messages :
    4369
    "J'aime" reçus :
    60
    Sexe :
    Masculin
    Habite à:
    Savigny le Temple 77176
    Utilise:
    Excel 2010 (PC)
    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 :
    Code (Visual Basic):
    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 :
    Code (Visual Basic):
    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
     
  9. grisan29

    grisan29 XLDnaute Accro

    Inscrit depuis le :
    26 Mai 2008
    Messages :
    1745
    "J'aime" reçus :
    38
    Sexe :
    Masculin
    Habite à:
    plouescat (29N)
    Utilise:
    Excel 2013 (PC)
    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:
    dossiers pour enregister sous.jpg
    ainsi que dans le dossier "facture seule"
    rangement sous d.jpg
    et enfin la sauvegarde dans les dossiers
    sauvegarde.jpg
    mais la sauvegarde ne doit pas se faire 2017-07 2017-08 etc
     
    Dernière édition: 17 Juillet 2017
  10. grisan29

    grisan29 XLDnaute Accro

    Inscrit depuis le :
    26 Mai 2008
    Messages :
    1745
    "J'aime" reçus :
    38
    Sexe :
    Masculin
    Habite à:
    plouescat (29N)
    Utilise:
    Excel 2013 (PC)
    bonsoir bèbère
    j'ai fait un test la sauverde .pdf se fait sans bug mais pas comme il faut
     

    Pièces jointes:

  11. grisan29

    grisan29 XLDnaute Accro

    Inscrit depuis le :
    26 Mai 2008
    Messages :
    1745
    "J'aime" reçus :
    38
    Sexe :
    Masculin
    Habite à:
    plouescat (29N)
    Utilise:
    Excel 2013 (PC)
    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 (Text):
    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
     
  12. Bebere

    Bebere XLDnaute Barbatruc

    Inscrit depuis le :
    8 Mai 2005
    Messages :
    5747
    "J'aime" reçus :
    70
    Habite à:
    Tongres
    Utilise:
    Excel 2003 (PC)
    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
     
  13. grisan29

    grisan29 XLDnaute Accro

    Inscrit depuis le :
    26 Mai 2008
    Messages :
    1745
    "J'aime" reçus :
    38
    Sexe :
    Masculin
    Habite à:
    plouescat (29N)
    Utilise:
    Excel 2013 (PC)
    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 (Text):
     Case DOC_DEVIS

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

    Bebere XLDnaute Barbatruc

    Inscrit depuis le :
    8 Mai 2005
    Messages :
    5747
    "J'aime" reçus :
    70
    Habite à:
    Tongres
    Utilise:
    Excel 2003 (PC)
    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 (Text):
    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
     
     
    Dernière édition: 18 Juillet 2017
  15. ChTi160

    ChTi160 XLDnaute Barbatruc

    Inscrit depuis le :
    20 Février 2005
    Messages :
    4369
    "J'aime" reçus :
    60
    Sexe :
    Masculin
    Habite à:
    Savigny le Temple 77176
    Utilise:
    Excel 2010 (PC)
    Bonjour Grisan
    Bonjour Le fil (Bebere) ,Le Forum
    je viens de tester
    pour définir ce que renvoie
    Code (Visual Basic):
    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
     
  16. Bebere

    Bebere XLDnaute Barbatruc

    Inscrit depuis le :
    8 Mai 2005
    Messages :
    5747
    "J'aime" reçus :
    70
    Habite à:
    Tongres
    Utilise:
    Excel 2003 (PC)
    bonjour Jean Marie
    bien sûr tu auras 10 à la page 9
    changé dans le code
    edit:je pourrais chanter
    J'ai la mémoire qui flanche,je ne me souviens plus très bien.....
     
  17. grisan29

    grisan29 XLDnaute Accro

    Inscrit depuis le :
    26 Mai 2008
    Messages :
    1745
    "J'aime" reçus :
    38
    Sexe :
    Masculin
    Habite à:
    plouescat (29N)
    Utilise:
    Excel 2013 (PC)
    bonjour Bebère, chti160 et le forum
    j'ai épuré au max le classeur et le voici compresser avec les dossiers qui se mettent sous c: ou d: où ?
    ah oui le classeur joint est un essai fait avec le code de Bèbère c'est pour cela qu'il a pris le nom de sauvegarde et cela est normal sur le fichier original
    ce classeur est a mettre sur le bureau ou en raccourci comme je l'utilise
    en fait je suis en cours de le refaire pour enlever les listviews
    je m'excuse s'il y a des bug suite la suppression des userform et codes superflu pour le test, je vais essayer d'y remédier au mieux mais pas de suite
     
    Dernière édition: 18 Juillet 2017
  18. Bebere

    Bebere XLDnaute Barbatruc

    Inscrit depuis le :
    8 Mai 2005
    Messages :
    5747
    "J'aime" reçus :
    70
    Habite à:
    Tongres
    Utilise:
    Excel 2003 (PC)
    bonjour
    Grisan un code qui fait son boulot
    mis en commentaire les lignes qui gênaient
    Code (Text):
    Option Explicit
    'notes
    'Constante DIR_WORKSPACE  = "D:\Facturation-v1s\factureSeule"

    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)
      'ces lignes sont elles bonnes
    'je pense a ceçi:si I17="" alors update et I17=true
      '        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 = DIR_WORKSPACE & CheminXL & "PDF\" & Format(Date, "yyyy") & "\" & Format(Date, "mmmm") & "\"
        CreateFolders CheminPDF 'mgestion
        CheminXL = DIR_WORKSPACE & CheminXL & "\" & Format(Date, "yyyy") & "\" & Format(Date, "mmmm") & "\"
        CreateFolders CheminXL 'mgestion
        ' Sauvegarder le classeur actif dans le chemin et le nom determiné
        ' FileFormat:=xlExcel8,
        ActiveWorkbook.SaveAs Filename:=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
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=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
     
  19. grisan29

    grisan29 XLDnaute Accro

    Inscrit depuis le :
    26 Mai 2008
    Messages :
    1745
    "J'aime" reçus :
    38
    Sexe :
    Masculin
    Habite à:
    plouescat (29N)
    Utilise:
    Excel 2013 (PC)
    bonjour Bébère
    Merci je n'ai fait qu'un ou 2 essai car je dois partir, mais je repousse mes essais plus tard
    j'ai du mettre ces 2 lignes en commetaires car elles bugais au faisant appel a la fonction getfolders
    ' CreateFolders CheminPDF 'mgestion
    ' CreateFolders CheminXL 'mgestion
    merci aussi pour le chemin de la constantes que j'ai oublier de changer car pour mes essais j'ai changer de lieu de sauvegarde
     
  20. grisan29

    grisan29 XLDnaute Accro

    Inscrit depuis le :
    26 Mai 2008
    Messages :
    1745
    "J'aime" reçus :
    38
    Sexe :
    Masculin
    Habite à:
    plouescat (29N)
    Utilise:
    Excel 2013 (PC)
    bonjour Bebere:)
    merci BEAUCOUP:):) maintenant c'est le code qui enregistre sans les codes et boutons qui me pose le même souci et je ne sais pas bien appliqué les x ou ils ne vont pas la
    il est du même cru que celui du post 3
    Code (Text):
    Public Sub envoifacnue()    '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)

            Select Case F.Range("DOC_TYPE")
            Case DOC_DEVIS
                Chemin = "C:\Facturation\Facture seule\devis" & Annee & Mois
                If Dir(Chemin, vbDirectory) = "" Then
                    MkDir Chemin
                End If
        Case DOC_FACT_ACC
            Chemin = "C:\Facturation\Facture seule\facture acompte\" & Annee & Mois
            If Dir(Chemin, vbDirectory) = "" Then
                MkDir Chemin
            End If
        Case DOC_FACT_AQUI
            Chemin = "C:\Facturation\Facture seule\facture acquittee\" & Annee & Mois
            If Dir(Chemin, vbDirectory) = "" Then
                MkDir Chemin
            End If
        Case DOC_FACT
            Chemin = "C:\Facturation\Facture seule\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

        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
     

Partager cette page