Compteur excel - compteur à chaque impression

Monhtc

XLDnaute Occasionnel
J’ai un fichier excel dans lequel je numérote le document. J’aimerais que la numérotation se fasse automatiquement dans la celulle B9 à chaque impression sous le format N 001/"mois"/"année"/MICROSOFT/EXCEL
Si quelqu’un a une solution pour moi je suis preneur d’autant plus que je ne suis pas expert dans l’utilisation d’excel…

Merci d’avance
 

job75

XLDnaute Barbatruc
Bonjour Monhtc,

Placez cette macro dans ThisWorkbook et menu FICHIER => Imprimer :
VB:
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim c As Range, test As Boolean
Cancel = True 'pour tester sans imprimer, à supprimer pour imprimer
Set c = Sheets("Feuil1").[B9] 'nom de la feuille à adapter
test = c Like "N ###/##/####/MICROSOFT/EXCEL" And Format(Month(Date), "00") = Mid(c, 7, 2) And Year(Date) = Val(Mid(c, 10, 4))
c = IIf(test, "N " & Format(Val(Mid(c, 3, 3)) + 1, "000") & Mid(c, 6, 99), "N 001/" & Format(Date, "mm/yyyy") & "/MICROSOFT/EXCEL")
End Sub
Le numéro est incrémenté à chaque impression et revient à 001 chaque fois que la date du jour change de mois ou d'année.

Comme indiqué supprimez Cancel = True pour imprimer.

A+
 

Monhtc

XLDnaute Occasionnel
Merci Job75 pour votre assistance
j'ai joint au fichier. Par ailleurs je souhaite que ce numéro soit remis à 0 chaque début d'un nouveau mois et d'une nouvelle année plutôt que chaque jour... MERCI INFINIMENT
 

Pièces jointes

  • AAAAA.xlsm
    94.4 KB · Affichages: 21

job75

XLDnaute Barbatruc
Par ailleurs je souhaite que ce numéro soit remis à 0 chaque début d'un nouveau mois et d'une nouvelle année plutôt que chaque jour...
Si vous comprenez le français :
Le numéro est incrémenté à chaque impression et revient à 001 chaque fois que la date du jour change de mois ou d'année.
Sinon vous n'avez qu'à tester mon code qui doit être placé, je le répète, dans ThisWorkbook.
 

job75

XLDnaute Barbatruc
Bonjour Monhtc, le forum,
Mais comment puis-je enregistrer (beforeprint) en format pdf
Toujours dans ThisWorkbook :
VB:
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim n As Byte, c As Range, test As Boolean, fichier
With Sheets("Feuil1") 'nom de la feuille à adapter
    .Activate
    n = MsgBox("Imprimer en PDF ?", 3, "Imprimer")
    If n = vbCancel Then Cancel = True: Exit Sub
    Set c = .[B9]
    test = c Like "N ###/##/####/MICROSOFT/EXCEL" And Format(Month(Date), "00") = Mid(c, 7, 2) And Year(Date) = Val(Mid(c, 10, 4))
    c = IIf(test, "N " & Format(Val(Mid(c, 3, 3)) + 1, "000") & Mid(c, 6, 99), "N 001/" & Format(Date, "mm/yyyy") & "/MICROSOFT/EXCEL")
    If n = vbYes Then
        Cancel = True 'annule l'impression normale
        fichier = ThisWorkbook.Path & "\" & c & " - " & .[D12] 'à adapter
        Application.EnableEvents = False 'désactive les évènements
        .ExportAsFixedFormat xlTypePDF, Replace(fichier, "/", " ") 'le slash / est un caratère interdit
        Application.EnableEvents = True 'réactive les évènements
    End If
End With
End Sub
Il faut éviter les caractères interdits dans les noms des fichiers \ / : * ? " < > |

A+
 

job75

XLDnaute Barbatruc
Avec la macro précédente seule la feuille indiquée peut être imprimée.

Si l'on veut pouvoir imprimer les autres feuilles du classeur (sans incrémenter de numéro) :
VB:
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim n As Byte, c As Range, test As Boolean, fichier
With Sheets("Feuil1") 'nom de la feuille à adapter
    If ActiveSheet.Name <> .Name Then Exit Sub 'permet d'imprimer d'autres feuilles
    n = MsgBox("Imprimer en PDF ?", 3, "Imprimer")
    If n = vbCancel Then Cancel = True: Exit Sub
    Set c = .[B9]
    test = c Like "N ###/##/####/MICROSOFT/EXCEL" And Format(Month(Date), "00") = Mid(c, 7, 2) And Year(Date) = Val(Mid(c, 10, 4))
    c = IIf(test, "N " & Format(Val(Mid(c, 3, 3)) + 1, "000") & Mid(c, 6, 99), "N 001/" & Format(Date, "mm/yyyy") & "/MICROSOFT/EXCEL")
    If n = vbYes Then
        Cancel = True 'annule l'impression normale
        fichier = ThisWorkbook.Path & "\" & c & " - " & .[D12] 'à adapter
        Application.EnableEvents = False 'désactive les évènements
        .ExportAsFixedFormat xlTypePDF, Replace(fichier, "/", " ") 'le slash / est un caratère interdit
        Application.EnableEvents = True 'réactive les évènements
    End If
End With
End Sub
 

Monhtc

XLDnaute Occasionnel
Merci Jobs tous marche à merveille. sauf que lorsque j'ai modifier le préfixe en rajoutant le symbole numéro (°), la série ne s’incrémente plus.
voici mon code modifier.
VB:
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim n As Byte, c As Range, test As Boolean, fichier
With Sheets("MENU")
.Activate
n = MsgBox("Imprimer en PDF ?", 3, "Imprimer")
If n = vbCancel Then Cancel = True: Exit Sub
Set c = .[B9]
test = c Like "N°CC ###-##/####/MICROSOFT/EXCEL" And Format(Month(Date), "00") = Mid(c, 7, 2) And Year(Date) = Val(Mid(c, 10, 4))
c = IIf(test, "N°CC" & Format(Val(Mid(c, 3, 3)) + 1, "000") & Mid(c, 6, 99), "N°CC 001-" & Format(Date, "mm/yyyy") & "/MICROSOFT/EXCEL")
If n = vbYes Then
Cancel = True
fichier = ThisWorkbook.Path & "\" & c & " - " & .[D12] 'à adapter
Application.EnableEvents = False 'désactive les évènements
.ExportAsFixedFormat xlTypePDF, Replace(fichier, "/", " ")
Application.EnableEvents = True 'réactive les évènements
End If
End With
 

job75

XLDnaute Barbatruc
Bonjour Monhtc,

Puisqu'on ajoute 3 caractères il faut décaler de 3 dans les fonctions Mid :
VB:
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim n As Byte, c As Range, test As Boolean, fichier
With Sheets("MENU") 'nom de la feuille à adapter
    If ActiveSheet.Name <> .Name Then Exit Sub 'permet d'imprimer d'autres feuilles
    n = MsgBox("Imprimer en PDF ?", 3, "Imprimer")
    If n = vbCancel Then Cancel = True: Exit Sub
    Set c = .[B9]
    test = c Like "N°CC ###/##/####/MICROSOFT/EXCEL" And Format(Month(Date), "00") = Mid(c, 10, 2) And Year(Date) = Val(Mid(c, 13, 4))
    c = IIf(test, "N°CC " & Format(Val(Mid(c, 6, 3)) + 1, "000") & Mid(c, 9, 99), "N°CC 001/" & Format(Date, "mm/yyyy") & "/MICROSOFT/EXCEL")
    If n = vbYes Then
        Cancel = True 'annule l'impression normale
        fichier = ThisWorkbook.Path & "\" & c & " - " & .[D12] 'à adapter
        Application.EnableEvents = False 'désactive les évènements
        .ExportAsFixedFormat xlTypePDF, Replace(fichier, "/", " ") 'le slash / est un caratère interdit
        Application.EnableEvents = True 'réactive les évènements
    End If
End With
End Sub
A+
 

Monhtc

XLDnaute Occasionnel
J'au rajouter à la suite du code "befrore print" celui ci pour sauvegarder sur une seconde feuille mes elements question de consitituer une base de données mais elle ne s'alimente pas:
VB:
C = Worksheets("Feuil2").Range("A2").Value
Worksheets("Feuil1").Range("D12").Value = Worksheets("Feuil2").Range("B2").Value
Worksheets("Feuil1").Range("D13").Value = Worksheets("Feuil2").Range("C2").Value
Worksheets("Feuil1").Range("D14").Value = Worksheets("Feuil2").Range("D2").Value
Worksheets("Feuil1").Range("D15").Value = Worksheets("Feuil2").Range("E2").Value
Worksheets("Feuil1").Range("D16").Value = Worksheets("Feuil2").Range("F2").Value
Worksheets("Feuil1").Range("D17").Value = Worksheets("Feuil2").Range("G2").Value
Worksheets("Feuil1").Range("G4").Value = Worksheets("Feuil2").Range("H2").Value
Worksheets("Feuil1").Range("G6").Value = Worksheets("Feuil2").Range("I2").Value
 

Monhtc

XLDnaute Occasionnel
Bonjour Job75 j'ai essayé de compléter mon code dans l'objetif de pouvoir copier la valeur de cellule de la feuille 1 dans un tableau dans la feuille 2 en vue de renseigner une base de données
VB:
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim n As Byte, c As Range, test As Boolean, fichier
With Sheets("MENU") 'nom de la feuille à adapter
    If ActiveSheet.Name <> .Name Then Exit Sub 'permet d'imprimer d'autres feuilles
    n = MsgBox("Imprimer en PDF ?", 3, "Imprimer")
    If n = vbCancel Then Cancel = True: Exit Sub
    Set c = .[B9]
    test = c Like "N°CC ###/##/####/MICROSOFT/EXCEL" And Format(Month(Date), "00") = Mid(c, 10, 2) And Year(Date) = Val(Mid(c, 13, 4))
    c = IIf(test, "N°CC " & Format(Val(Mid(c, 6, 3)) + 1, "000") & Mid(c, 9, 99), "N°CC 001/" & Format(Date, "mm/yyyy") & "/MICROSOFT/EXCEL")
    If n = vbYes Then
        Cancel = True 'annule l'impression normale
        fichier = ThisWorkbook.Path & "\" & c & " - " & .[D12] 'à adapter
        Application.EnableEvents = False 'désactive les évènements
        .ExportAsFixedFormat xlTypePDF, Replace(fichier, "/", " ") 'le slash / est un caratère interdit
        Application.EnableEvents = True 'réactive les évènements
    End If
End With
C = Worksheets("Feuil2").Range("A2").Value
Worksheets("Feuil1").Range("D12").Value = Worksheets("Feuil2").Range("B2").Value
Worksheets("Feuil1").Range("D13").Value = Worksheets("Feuil2").Range("C2").Value
Worksheets("Feuil1").Range("D14").Value = Worksheets("Feuil2").Range("D2").Value
Worksheets("Feuil1").Range("D15").Value = Worksheets("Feuil2").Range("E2").Value
Worksheets("Feuil1").Range("D16").Value = Worksheets("Feuil2").Range("F2").Value
Worksheets("Feuil1").Range("D17").Value = Worksheets("Feuil2").Range("G2").Value
Worksheets("Feuil1").Range("G4").Value = Worksheets("Feuil2").Range("H2").Value
Worksheets("Feuil1").Range("G6").Value = Worksheets("Feuil2").Range("I2").Value
End Sub
 

Discussions similaires

Statistiques des forums

Discussions
311 740
Messages
2 082 041
Membres
101 879
dernier inscrit
Arthur M