XL 2013 Modification d'une macr

momo · 27 Décembre 2018

Bonjour à tous

J'ai obtenu e bon fichier qu permet de lancer une procédure pour imprimer.

Elle permet entre autre d'afficher toutes les feuilles d'un classeur Excel et de pouvoir sélectionner les feuilles voulues et lancer une impression

Je sollicite votre aide pour adapter un peu le fichier.

- Je voudrais qu'il n'affiche pas toutes les feuilles (Certaines feuilles sont des feuilles de calcul à ne pas imprimer)
- Je voudrais également pouvoir masquer des lignes à la condition que les cellules B et C ou C D selon les feuilles contiennent simultanément la valeur o

vmax01 · 28 Décembre 2018

bonjour Momo, le forum,

ton classeur est complémentent vide, il est difficile de déterminer quelles feuilles ne sont pas a afficher et pour ce qui est des colonnes a cacher, en fonction d'une valeur 0 qui se trouve ou ?
donne nous au moins un dossier un peu plus fournis avec tenant et aboutissant, des entêtes ... et non un dossier vierge.

momo · 28 Décembre 2018

vmax01 à dit:
bonjour Momo, le forum,

ton classeur est complémentent vide, il est difficile de déterminer quelles feuilles ne sont pas a afficher et pour ce qui est des colonnes a cacher, en fonction d'une valeur 0 qui se trouve ou ?
donne nous au moins un dossier un peu plus fournis avec tenant et aboutissant, des entêtes ... et non un dossier vierge.

Bonjour Max, Bonjour le Forum

En effet tu as raison je mets un classeur plus explicite.

Sur le point du masque des lignes , mapomme m'a bien aidé à trouver une solution (Les lignes se masquent lorsque on clique sur les onglets) mais pour un soucis de lisibilité, je voudrais que ces lignes ne se masque que lorsque on veut imprimer les feuilles concernées.

Ps: ceci est le lien vers la solution que m'avait trouvé mapomme: https://www.excel-downloads.com/threads/résolu-masquer-afficher-automatiquement-des-lignes-suivant-critères-sur-deux-colon.20027909/#post-20210353

momo · 28 Décembre 2018

momo à dit:
Bonjour Max, Bonjour le Forum

En effet tu as raison je mets un classeur plus explicite.

Sur le point du masque des lignes , mapomme m'a bien aidé à trouver une solution (Les lignes se masquent lorsque on clique sur les onglets) mais pour un soucis de lisibilité, je voudrais que ces lignes ne se masque que lorsque on veut imprimer les feuilles concernées.

Ps: ceci est le lien vers la solution que m'avait trouvé mapomme: https://www.excel-downloads.com/threads/résolu-masquer-afficher-automatiquement-des-lignes-suivant-critères-sur-deux-colon.20027909/#post-20210353

Bonsoir Max, Bonsoir le Forum

Vous n'auriez pas une piste de réponse pour ma requête pls

momo · 29 Décembre 2018

Bonjour à tous

Je voudrais savoir si en l'espèce, le sujet n'était pas possible à résoudre, pour que je puisse abandonner l'idée de voir ça marcher

job75 · 29 Décembre 2018

Bonjour momo, vmax01,

momo à dit:
Je voudrais savoir si en l'espèce, le sujet n'était pas possible à résoudre, pour que je puisse abandonner l'idée de voir ça marcher

Bien sûr que c'est faisable mais vous débarquez avec un UserForm et des macros, ce n'est pas très passionnant de les modifier.

Sans se préoccuper de l'UserForm voyez cette macro :

Code:

Sub Imprimer()
Dim exclu, w As Worksheet, Roc As Range, Cor As Range, derlig&
exclu = Array("Pomme", "Raisin", "Clémentine", "Melon", "Pastèque")
For Each w In Worksheets
    If IsError(Application.Match(w.Name, exclu, 0)) Then
        Set Roc = w.Cells.Find("Roc", , xlValues, xlWhole)
        Set Cor = w.Cells.Find("Cor")
        If Not Roc Is Nothing And Not Cor Is Nothing Then
            If Roc.Row = Cor.Row Then
                derlig = w.Cells.SpecialCells(xlCellTypeLastCell).Row
                Do While Roc.Row < derlig
                    Set Roc = Roc(2): Set Cor = Cor(2)
                    If Roc = 0 And Cor = 0 Then Roc.EntireRow.Hidden = True
                Loop
            End If
        End If
        w.PrintOut 'imprime la feuille
        w.Rows.Hidden = False 'RAZ
    End If
Next
End Sub

A+

momo · 29 Décembre 2018

job75 à dit:
Sub Imprimer()
Dim exclu, w As Worksheet, Roc As Range, Cor As Range, derlig&
exclu = Array("Pomme", "Raisin", "Clémentine", "Melon", "Pastèque")
For Each w In Worksheets
If IsError(Application.Match(w.Name, exclu, 0)) Then
Set Roc = w.Cells.Find("Roc", , xlValues, xlWhole)
Set Cor = w.Cells.Find("Cor")
If Not Roc Is Nothing And Not Cor Is Nothing Then
If Roc.Row = Cor.Row Then
derlig = w.Cells.SpecialCells(xlCellTypeLastCell).Row
Do While Roc.Row < derlig
Set Roc = Roc(2): Set Cor = Cor(2)
If Roc = 0 And Cor = 0 Then Roc.EntireRow.Hidden = True
Loop
End If
End If
w.PrintOut 'imprime la feuille
w.Rows.Hidden = False 'RAZ
End If
Next
End Sub

Bonjour Job
La macro est parfaite, par contre
- Lorsque l'impression doit se faire sous format PDF, elle enregistre feuille par feuille, est-il possible de l'enregistrer sous un classeur unique dans ce cas?
- pourrais-t-on avoir la possibilité de ne xporter en PDf ou de ne imprimer qu'une sélection de feuille? dans le cas où on ne voudrais pas forcément imprimer toutes les feuilles non exclues ?

- une troisième requête si je peux me permettre
Est-i possible d'exporter égalemnt vers un autre classue Excel mais ceci sans les formules ni macro existants dans le classeur originel

Merci pour toute l'aide que vous me portez
Momo

job75 · 29 Décembre 2018

Re,

Cette macro dans le fichier joint fait ce que vous souhaitez :

Code:

Sub Exporter()
Dim exclu, w As Worksheet, n%, liste$(), wb As Workbook, Roc As Range, Cor As Range, derlig&, chemin$, nom1$, nom2
exclu = Array("Pomme", "Raisin", "Clémentine", "Melon", "Pastèque")
'---choix des feuilles--
For Each w In Worksheets
    If IsError(Application.Match(w.Name, exclu, 0)) Then
        If MsgBox("Exporter '" & w.Name & "' ?", 4) = 6 Then
            n = n + 1
            ReDim Preserve liste(1 To n)
            liste(n) = w.Name
        End If
    End If
Next
If n = 0 Then MsgBox "Aucune feuille n'a été choisie...": Exit Sub
'---copie dans un document auxiliaire---
Application.ScreenUpdating = False
Set wb = Workbooks.Add(xlWBATWorksheet)
For Each w In ThisWorkbook.Worksheets
    If IsNumeric(Application.Match(w.Name, liste, 0)) Then
        Set Roc = w.Cells.Find("Roc", , xlValues, xlWhole)
        Set Cor = w.Cells.Find("Cor")
        If Not Roc Is Nothing And Not Cor Is Nothing Then
            If Roc.Row = Cor.Row Then
                derlig = w.Cells.SpecialCells(xlCellTypeLastCell).Row
                Do While Roc.Row < derlig
                    Set Roc = Roc(2): Set Cor = Cor(2)
                    If Roc = 0 And Cor = 0 Then Roc.EntireRow.Hidden = True
                Loop
            End If
        End If
        w.Copy After:=wb.Sheets(wb.Sheets.Count)
        wb.Sheets(wb.Sheets.Count).UsedRange = w.UsedRange.Value 'supprime les formules
        wb.Sheets(wb.Sheets.Count).Name = w.Name
        w.Rows.Hidden = False 'RAZ
    End If
Next
'---création des fichiers Excel et PDF---
chemin = ThisWorkbook.Path & "\" 'à adapter
Application.DisplayAlerts = False
wb.Sheets(1).Delete
nom1 = "Excel " & Format(Now, "yyyy-mm-dd hhmmss")
wb.SaveAs chemin & "Excel " & nom1
Set w = wb.Sheets(1)
For n = 2 To wb.Sheets.Count
    With w.Rows(w.UsedRange.Row + w.UsedRange.Rows.Count)
        wb.Sheets(n).UsedRange.EntireRow.Copy .Cells
        w.HPageBreaks.Add Before:=.Cells(1) 'saut de page
    End With
Next
w.PageSetup.PrintArea = w.UsedRange.Address 'zone d'impression
nom2 = "PDF " & Mid(nom1, 7)
w.ExportAsFixedFormat xlTypePDF, chemin & nom2, Quality:=xlQualityStandard
wb.Close False 'fermeture du fichier Excel
Application.ScreenUpdating = True
MsgBox "Fichiers '" & nom1 & "' et '" & nom2 & "' créés..."
End Sub

A+

momo · 29 Décembre 2018

job75 à dit:

Re,

Cette macro dans le fichier joint fait ce que vous souhaitez :

Code:

Sub Exporter()
Dim exclu, w As Worksheet, n%, liste$(), wb As Workbook, Roc As Range, Cor As Range, derlig&, chemin$, nom1$, nom2
exclu = Array("Pomme", "Raisin", "Clémentine", "Melon", "Pastèque")
'---choix des feuilles--
For Each w In Worksheets
    If IsError(Application.Match(w.Name, exclu, 0)) Then
        If MsgBox("Exporter '" & w.Name & "' ?", 4) = 6 Then
            n = n + 1
            ReDim Preserve liste(1 To n)
            liste(n) = w.Name
        End If
    End If
Next
If n = 0 Then MsgBox "Aucune feuille n'a été choisie...": Exit Sub
'---copie dans un document auxiliaire---
Application.ScreenUpdating = False
Set wb = Workbooks.Add(xlWBATWorksheet)
For Each w In ThisWorkbook.Worksheets
    If IsNumeric(Application.Match(w.Name, liste, 0)) Then
        Set Roc = w.Cells.Find("Roc", , xlValues, xlWhole)
        Set Cor = w.Cells.Find("Cor")
        If Not Roc Is Nothing And Not Cor Is Nothing Then
            If Roc.Row = Cor.Row Then
                derlig = w.Cells.SpecialCells(xlCellTypeLastCell).Row
                Do While Roc.Row < derlig
                    Set Roc = Roc(2): Set Cor = Cor(2)
                    If Roc = 0 And Cor = 0 Then Roc.EntireRow.Hidden = True
                Loop
            End If
        End If
        w.Copy After:=wb.Sheets(wb.Sheets.Count)
        wb.Sheets(wb.Sheets.Count).UsedRange = w.UsedRange.Value 'supprime les formules
        wb.Sheets(wb.Sheets.Count).Name = w.Name
        w.Rows.Hidden = False 'RAZ
    End If
Next
'---création des fichiers Excel et PDF---
chemin = ThisWorkbook.Path & "\" 'à adapter
Application.DisplayAlerts = False
wb.Sheets(1).Delete
nom1 = "Excel " & Format(Now, "yyyy-mm-dd hhmmss")
wb.SaveAs chemin & "Excel " & nom1
Set w = wb.Sheets(1)
For n = 2 To wb.Sheets.Count
    With w.Rows(w.UsedRange.Row + w.UsedRange.Rows.Count)
        wb.Sheets(n).UsedRange.EntireRow.Copy .Cells
        w.HPageBreaks.Add Before:=.Cells(1) 'saut de page
    End With
Next
w.PageSetup.PrintArea = w.UsedRange.Address 'zone d'impression
nom2 = "PDF " & Mid(nom1, 7)
w.ExportAsFixedFormat xlTypePDF, chemin & nom2, Quality:=xlQualityStandard
wb.Close False 'fermeture du fichier Excel
Application.ScreenUpdating = True
MsgBox "Fichiers '" & nom1 & "' et '" & nom2 & "' créés..."
End Sub

A+

Bonsoir Job!

Franchement la macro est parfaite!
et comme vous le dites vous même elle fait selon les voeux que j'ai émis .
Par contre, par rapport aux choix des feuilles, j'ai bien peur que les messages qui demandent si oui ou non on veut exporter telle ou telle feuille deviennent un peu fastidieux au regard de mon classeur qui comporte près de 60 onglets dont à peine une dizaine seront exclu de la sélection.

Je ne sais pas si il peut y avoir une solution pour ça comme par exemple créer une forme de liste déroulante dans laquelle on pourra choisir les onglets voulu

job75 · 29 Décembre 2018

Re,

Dans ce fichier (2) :

- une liste des feuilles exclues est à compléter manuellement

- je me suis rendu compte que les sauts de page (HPageBreaks) ne fonctionnent pas quand on fait la mise en page "1 page en largeur", j'utilise donc maintenant une zone d'impression multiple (constituée de plages disjointes).

La macro :

Code:

Sub Exporter()
Dim liste As Range, wb As Workbook, w As Worksheet, Roc As Range, Cor As Range, derlig&, chemin$, nom1$, pa As Range, n%, nom2$
ActiveSheet.Protect "momo", UserInterfaceOnly:=True 'mot de passe à adapter
Set liste = [F3].CurrentRegion 'à adapter
If Application.CountBlank(liste.Columns(2)) = 0 Then MsgBox "Toutes les feuilles sont exclues !": Exit Sub
'---copie dans un document auxiliaire---
Application.ScreenUpdating = False
Set wb = Workbooks.Add(xlWBATWorksheet)
For Each w In ThisWorkbook.Worksheets
    If IsNumeric(Application.VLookup(w.Name, liste, 2, 0)) Then 'RECHERCHEV
        Set Roc = w.Cells.Find("Roc", , xlValues, xlWhole)
        Set Cor = w.Cells.Find("Cor")
        If Not Roc Is Nothing And Not Cor Is Nothing Then
            If Roc.Row = Cor.Row Then
                derlig = w.Cells.SpecialCells(xlCellTypeLastCell).Row
                Do While Roc.Row < derlig
                    Set Roc = Roc(2): Set Cor = Cor(2)
                    If Roc = 0 And Cor = 0 Then Roc.EntireRow.Hidden = True
                Loop
            End If
        End If
        w.Copy After:=wb.Sheets(wb.Sheets.Count)
        wb.Sheets(wb.Sheets.Count).UsedRange = w.UsedRange.Value 'supprime les formules
        wb.Sheets(wb.Sheets.Count).Name = w.Name
        w.Rows.Hidden = False 'RAZ
    End If
Next
'---création des fichiers Excel et PDF---
chemin = ThisWorkbook.Path & "\" 'à adapter
Application.DisplayAlerts = False
wb.Sheets(1).Delete
nom1 = "Excel " & Format(Now, "yyyy-mm-dd hhmmss")
wb.SaveAs chemin & nom1
Set w = wb.Sheets(1)
Set pa = w.UsedRange
For n = 2 To wb.Sheets.Count
    With w.Rows(w.UsedRange.Row + w.UsedRange.Rows.Count + 1) 'décalage d'une ligne
        wb.Sheets(n).UsedRange.EntireRow.Copy .Cells
        Set pa = Union(pa, Intersect(w.UsedRange, .Resize(w.Rows.Count - .Row + 1)))
    End With
Next
w.PageSetup.Zoom = False
w.PageSetup.FitToPagesWide = 1 'une page en largeur
w.PageSetup.PrintArea = pa.Address 'zone d'impression multiple
nom2 = "PDF " & Mid(nom1, 7)
w.ExportAsFixedFormat xlTypePDF, chemin & nom2, Quality:=xlQualityStandard
wb.Close False 'fermeture du fichier Excel
Application.ScreenUpdating = True
MsgBox "Fichiers '" & nom1 & "' et '" & nom2 & "' créés..."
End Sub

A+

momo · 29 Décembre 2018

job75 à dit:

Re,

Dans ce fichier (2) :

- une liste des feuilles exclues est à compléter manuellement

- je me suis rendu compte que les sauts de page (HPageBreaks) ne fonctionnent pas quand on fait la mise en page "1 page en largeur", j'utilise donc maintenant une zone d'impression multiple (constituée de plages disjointes).

La macro :

Code:

Sub Exporter()
Dim liste As Range, wb As Workbook, w As Worksheet, Roc As Range, Cor As Range, derlig&, chemin$, nom1$, pa As Range, n%, nom2$
ActiveSheet.Protect "momo", UserInterfaceOnly:=True 'mot de passe à adapter
Set liste = [F3].CurrentRegion 'à adapter
If Application.CountBlank(liste.Columns(2)) = 0 Then MsgBox "Toutes les feuilles sont exclues !": Exit Sub
'---copie dans un document auxiliaire---
Application.ScreenUpdating = False
Set wb = Workbooks.Add(xlWBATWorksheet)
For Each w In ThisWorkbook.Worksheets
    If IsNumeric(Application.VLookup(w.Name, liste, 2, 0)) Then 'RECHERCHEV
        Set Roc = w.Cells.Find("Roc", , xlValues, xlWhole)
        Set Cor = w.Cells.Find("Cor")
        If Not Roc Is Nothing And Not Cor Is Nothing Then
            If Roc.Row = Cor.Row Then
                derlig = w.Cells.SpecialCells(xlCellTypeLastCell).Row
                Do While Roc.Row < derlig
                    Set Roc = Roc(2): Set Cor = Cor(2)
                    If Roc = 0 And Cor = 0 Then Roc.EntireRow.Hidden = True
                Loop
            End If
        End If
        w.Copy After:=wb.Sheets(wb.Sheets.Count)
        wb.Sheets(wb.Sheets.Count).UsedRange = w.UsedRange.Value 'supprime les formules
        wb.Sheets(wb.Sheets.Count).Name = w.Name
        w.Rows.Hidden = False 'RAZ
    End If
Next
'---création des fichiers Excel et PDF---
chemin = ThisWorkbook.Path & "\" 'à adapter
Application.DisplayAlerts = False
wb.Sheets(1).Delete
nom1 = "Excel " & Format(Now, "yyyy-mm-dd hhmmss")
wb.SaveAs chemin & "Excel " & nom1
Set w = wb.Sheets(1)
Set pa = w.UsedRange
For n = 2 To wb.Sheets.Count
    With w.Rows(w.UsedRange.Row + w.UsedRange.Rows.Count + 1) 'décalage d'une ligne
        wb.Sheets(n).UsedRange.EntireRow.Copy .Cells
        Set pa = Union(pa, Intersect(w.UsedRange, .Resize(w.Rows.Count - .Row + 1)))
    End With
Next
w.PageSetup.Zoom = False
w.PageSetup.FitToPagesWide = 1 'une page en largeur
w.PageSetup.PrintArea = pa.Address 'zone d'impression multiple
nom2 = "PDF " & Mid(nom1, 7)
w.ExportAsFixedFormat xlTypePDF, chemin & nom2, Quality:=xlQualityStandard
wb.Close False 'fermeture du fichier Excel
Application.ScreenUpdating = True
MsgBox "Fichiers '" & nom1 & "' et '" & nom2 & "' créés..."
End Sub

A+

Aaaah J'adore votre fichier c'est génial...

Par contre je voudrais que vous me dites comment je fais pr que les fichiers créées portent le nom du document originel...

Aussi si je peux me permettre est il possible de créer deux boutons différents pour l'export en PDF et celui en Excel?

Merci merci Merci

job75 · 29 Décembre 2018

Re,

Bah j'en ai assez fait, travaillez un peu.

Je corrige juste dans mon post précédent le nom du fichier Excel, il y avait un "Excel" de trop...

A+

momo · 29 Décembre 2018

job75 à dit:
Re,

Bah j'en ai assez fait, travaillez un peu.

Je corrige juste dans mon post précédent le nom du fichier Excel, il y avait un "Excel" de trop...

A+

en tout cas vous avez bien raison ... vous en avez tellement déjà fait !

Merci encore pour tout

momo · 7 Janvier 2019

job75 à dit:
Re,

Bah j'en ai assez fait, travaillez un peu.

Je corrige juste dans mon post précédent le nom du fichier Excel, il y avait un "Excel" de trop...

A+

Bonsoir Job,

Je me permets de revenir sur ce fil pour une seule question

Comment avez vous bloqué la feuille par mot de passe en définissant une zone qui n'est pas bloquée

Auxssi:
wb.Sheets(wb.Sheets.Count).UsedRange = w.UsedRange.Value 'supprime les formules
cette formule entriane une laert du type "Erreur 1004", erreur définie par l'application ou par l'objet

job75 · 7 Janvier 2019

Bonsoir momo,

momo à dit:
Comment avez vous bloqué la feuille par mot de passe en définissant une zone qui n'est pas bloquée

Elémentaire : les cellules de la plage G7:G13 (en jaune) sont déverrouillées.

momo à dit:
wb.Sheets(wb.Sheets.Count).UsedRange = w.UsedRange.Value 'supprime les formules
cette formule entriane une laert du type "Erreur 1004", erreur définie par l'application ou par l'objet

Il y a une alerte si une ou plusieurs des feuilles à copier ont été protégées.

A+

XL 2013 Modification d'une macr

momo

XLDnaute Occasionnel

Pièces jointes

vmax01

XLDnaute Occasionnel

momo

XLDnaute Occasionnel

Pièces jointes

momo

XLDnaute Occasionnel

momo

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

momo

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Pièces jointes

momo

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Pièces jointes

momo

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

momo

XLDnaute Occasionnel

momo

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Discussions similaires

XL 2013 Modification d'une macr

XLDnaute Occasionnel

Pièces jointes

XLDnaute Occasionnel

XLDnaute Occasionnel

Pièces jointes

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency