XL 2016 Impression de plusieurs onglets

[fenec]

Bonjour le forum,

Dans le fichier joint, j’ai une macro qui me crée des onglets avec un nom défini, jusque-là tout va bien mais je ne parviens pas à faire la même chose pour imprimer ces onglets.
Je m’explique :
Je crée les onglets pour le mois de juillet alors que nous sommes en juin, je les modifie en fonction des données reçues. Le 28-06-2021, je décide d’imprimer la première semaine ou la première les quinzaine de juillet par exemple.

Je voudrais donc une macro qui par un input box me demanderais la période à imprimer plutôt que de sélectionner chaque onglet et l’imprimer un à un, faisant cette tâche à longueur d’année cela devient vite fastidieux.

J’espère que je me suis bien expliqué et merci d’avance pour l’aide que vous pourriez m’apporter.
Cordialement,
Philippe.

 

[bbb38]

Bonjour fenec, le forum,
En attendant une méthode avec la période à imprimer, une solution en sélectionnant les onglets à imprimer sur une ListBox.
Cordialement,
Bernard

 

[Bernard_XLD]

Bonjour fenec, bbb38, le forum

fenec , j'ai repris ta macro de création de feuille et l'ai modifiée pour l'impression. J'ai ajouté un deuxième bouton pour la lancer, j'ai aussi modifié ta zone d'impression de départ et refait un peu la mise en page pour les tests.
J'ai aussi revu la formule de la date de départ uniquement pour la génération des feuilles puisque tu as dit travailler dessus le mois précédent.

Bien cordialement, @+
Bernard, aussi

 

[job75]

Bonjour fenec, bbb38, Yeahou,

Ma solution avec ces 2 macros :

Sub CreerFeuillesMoisSuivant()
Dim F As Worksheet, jour&, nf$, w As Worksheet, i%, j%
Set F = Sheets("Tableau")
Application.ScreenUpdating = False
On Error Resume Next
For jour = DateSerial(Year(Date), Month(Date) + 1, 1) To DateSerial(Year(Date), Month(Date) + 2, 0)
    nf = Format(jour, "yyyy-mm-dd")
    Set w = Nothing
    Set w = Sheets(nf)
    If w Is Nothing Then 'si la feuille n'existe pas on la crée
        F.Copy After:=F
        ActiveSheet.Name = nf
        ActiveSheet.Range("B4").NumberFormat = "yyyy-mm-dd"
        ActiveSheet.Range("B4") = jour
        ActiveSheet.DrawingObjects.Delete
    End If
Next
'---tri des feuilles---
For i = F.Index + 1 To Sheets.Count
    For j = i + 1 To Sheets.Count
        If Sheets(j).Name < Sheets(i).Name Then Sheets(j).Move Before:=Sheets(i)
Next j, i
Sheets(Format(DateSerial(Year(Date), Month(Date) + 1, 1), "yyyy-mm-dd")).Activate
End Sub

Sub Imprimer()
Dim x$, test1 As Boolean, test2 As Boolean, s, dat1&, dat2&, jour&, nf$, w As Worksheet
Do
    x = InputBox("Entrez la 1ère et la dernière date séparées par un espace :", "Imprimer", x)
    If x = "" Then Exit Sub
    test1 = False: test2 = False
    s = Split(Trim(x))
    If UBound(s) > 0 Then test1 = IsDate(s(0)): test2 = IsDate(s(1))
Loop While Not test1 Or Not test2
dat1 = Int(CDate(s(0))): dat2 = Int(CDate(s(1)))
On Error Resume Next
For jour = Application.Min(dat1, dat2) To Application.Max(dat1, dat2)
    nf = Format(jour, "yyyy-mm-dd")
    Set w = Nothing
    Set w = Sheets(nf)
    If Not w Is Nothing Then w.PrintOut 'w.PrintPreview 'pour tester
Next
End Sub

A+

 

[fenec]

Bonjour bb38, Yeahou, job75

Déjà toute mes excuses pour ce retour tardif, petit soucis de santé mais bon rien de grave.

bb38
Ta solution est intéressante mais je ne souhaite pas sélectionner toute les feuilles une à une mais je garde ta réponse dans mes dossiers car elle peux être intéressantes pour d'autres projets.

Yeahou
Le fait d'avoir garder et modifier ma macro de départ pour l'impression est génial je peux voir les modification que je n'ai pas su effectuer, merci à toi.

job75
Quand je vois tes codes, je vois que je suis loin de donner des conseils en VBA, mais ce forum sert à apprendre des grands comme toi.

Voilà pour me retour tardif sans vouloir abuser de votre soutient, j'aurais encore besoin d'un petit coup de main.

Ayant éditer et imprimer ces tableaux, comment a partir de mon code de départ ou celui de job75 archiver les tableaux du mois précédent. Je sais pas si je suis clair, si besoin de renseignement suis à votre disposition.

Cordialement,

Philippe.

 

[Bernard_XLD]

Yeahou
Le fait d'avoir garder et modifier ma macro de départ pour l'impression est génial je peux voir les modification que je n'ai pas su effectuer, merci à toi.

Bonsoir le fil, fenec

C'était le but ! content que cela t'ait plu, je fais souvent cela pour ne pas imposer ma façon de programmer mais simplement corriger ce qui ne va pas dans le code fourni.
pour ta demande d'archivage, plusieurs façons de faire,
déplacer les feuilles dans un classeur archive
les imprimer en pdf puis supprimer les feuilles
les masquer dans le fichier originel
à toi de définir comment conserver les informations .

Bonne soirée, @+

 

[fenec]

Bonsoir Yeahou,
Tes remarques sont pertinentes.
Je souhaiterais archiver les tableaux du mois échu en les déplaçant dans un dossier en xlsx et les supprimer du fichier sources.
Bonne soirée, @+

 

[Bernard_XLD]

re,

Il te faut mieux préciser tes besoins:
comment désire tu les archiver, par dates de début et de fin comme tes autres macros ? ou par feuille active ? ou par feuilles sélectionnées ? par date dépassée de x mois ? automatiquement ou sur action de l'utilisateur ?
dans un seul fichier mis à jour ou un nouveau fichier à chaque fois ? une feuille par fichier ? Quel nom de fichier ? date de sauvegarde ou concaténation des noms de feuilles ?
à quel endroit ? un sous dossier spécifique ou au choix de l'utilisateur ?

plus tu seras précis et détaillé, plus ce sera facile pour les contributeurs qui n'auront pas à y revenir x fois pour te fournir un code adapté.

Bien cordialement, @+

 

[job75]

Bonjour fenec, Yeahou,

Sub Archiver()
Dim chemin$, F As Worksheet, i%, j%, jour&, nf$, w As Worksheet
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
Set F = Sheets("Tableau")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
'---tri des feuilles---
For i = F.Index + 1 To Sheets.Count
    For j = i + 1 To Sheets.Count
        If Sheets(j).Name < Sheets(i).Name Then Sheets(j).Move Before:=Sheets(i)
Next j, i
'---fichiers xlsx et suppressions---
For jour = DateSerial(Year(Date), Month(Date), 0) To DateSerial(Year(Date), Month(Date) - 1, 1) Step -1
    nf = Format(jour, "yyyy-mm-dd")
    Set w = Nothing
    Set w = Sheets(nf)
    If Not w Is Nothing Then
        w.Copy 'nouveau document
        ActiveWorkbook.SaveAs chemin & w.Name, 51 'format 51 : .xlsx
        ActiveWorkbook.Close
        w.Delete
    End If
Next
End Sub

On peut faire exécuter cette macro à la fin de la macro CreerFeuillesMoisSuivant du post #4.

A+

 

[fenec]

Bonjour forum,Yeahou,Job75

Je souhaiterais les archiver dans un fichier nommé "Sauvegarde Tableau" mis à jour à chaque archivage avec les dates des onglets au format "yyyy-mm-dd" anglais si je ne me trompe pas afin de pourvoir consolider les données par la suite avec un autre fichier.

Pour ce qui est de quand l’archivage aura lieu, je dirais que :

Comme nous sommes en juillet, les tableaux de juin ne devant plus être modifier on les archive et on les supprime du classeur. Le top serait en plus de les archiver, de les protéger contre toutes modifications.

J’espère avoir répondu à tes commentaires, si besoin de plus n’hésite pas.

Cordialement,

A te lire,@+

 

[fenec]

Re,job75

Nos post se sont croisés, je regarde ta proposition.

Cordialement,

 

[job75]

Bon j'ai modifié mon post #9 pour que ce soient les feuilles du mois précédent le mois en cours qui soient supprimées.

 

[job75]

En fait le tri n'est pas nécessaire, utilisez :

Sub Archiver()
Dim chemin$, jour&, nf$, w As Worksheet
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
For jour = DateSerial(Year(Date), Month(Date) - 1, 1) To DateSerial(Year(Date), Month(Date), 0)
    nf = Format(jour, "yyyy-mm-dd")
    Set w = Nothing
    Set w = Sheets(nf)
    If Not w Is Nothing Then
        w.Copy 'nouveau document
        ActiveWorkbook.SaveAs chemin & w.Name, 51 'format 51 : .xlsx
        ActiveWorkbook.Close
        w.Delete
    End If
Next
End Sub