XL 2016 Macro synthèse de plusieurs onglets

cdric78 · 6 Avril 2021

Bonjour à tous,

J'ai besoin de votre aide car j'ai un fichier Excel qui comprend une macro. Mais mon besoin à légèrement évolué mais je n'arrive pas à modifier la macro (je ne sais même pas s'il est possible de reprendre la macro actuelle).

J'explique mon besoin, dans l'onglet "Synthèse" il y a un bouton "Mise à jour" qui doit permettre de lister les contenu des lignes de tous les onglets n'ayant pas la valeur "terminé" en colonne J. Il faudrait pouvoir conserver la couleur appliquée en colonne A.

Dans le fichier en pièce jointe, j'ai ajouté manuellement le résultat des lignes potentiellement attendues.

Merci par avance pour votre aide car moi je n'ai malheureusement pas réussi à modifier la macro actuelle (j'ai préféré laissé la macro telle qu'elle était avant que je la bricole ;-) ).

Cdric78

job75 · 6 Avril 2021

Bonjour cdric78,

La macro du bouton ActiveX :

VB:

Private Sub CommandButton1_Click()
Dim lig&, w As Worksheet
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
Rows("5:" & Rows.Count).Delete 'RAZ
lig = 5
For Each w In Worksheets
    If w.Name <> Me.Name Then
        With w.Range("A4").CurrentRegion
            .AutoFilter 10, "<>Terminé" 'filtre automatique
            .EntireRow.Copy Cells(lig, 1)
            Rows(lig).Delete 'supprime les titres
            lig = lig + .Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
            .AutoFilter
        End With
    End If
Next
End Sub

A+

job75 · 6 Avril 2021

Bonjour cdric78,

La macro du bouton ActiveX :

VB:

Private Sub CommandButton1_Click()
Dim lig&, w As Worksheet
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
Rows("5:" & Rows.Count).Delete 'RAZ
lig = 5
For Each w In Worksheets
    If w.Name <> Me.Name Then
        With w.Range("A4").CurrentRegion
            .AutoFilter 10, "<>Terminé" 'filtre automatique
            .EntireRow.Copy Cells(lig, 1)
            Rows(lig).Delete 'supprime les titres
            lig = lig + .Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
            .AutoFilter
        End With
    End If
Next
End Sub

A+

cdric78 · 6 Avril 2021

Bonjour Job75,

Merci beaucoup pour ta réactivité et ton aide précieuse avec un résultat parfait .

Cdric78

Robert · 6 Avril 2021

Bonjour Cédric, bonjour le forum,

Essaie comme ça :

VB:

Sub Synthèse()
Dim OS As Worksheet 'déclare la variable OS (Onglet Synthèse)
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim PL As Range 'déclare la variable PL (PLage)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set OS = Worksheets("SYNTHESE") 'définit l'onglet OS
DL = OS.Cells(Application.Rows.Count, "A").End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne A de l'onglet OS
Range("A5:K" & DL).ClearContents 'supprime les anciennes valeurs
Range("A5:K" & DL).Interior.ColorIndex = xlNone 'supprime les anciennes couleurs
Set PL = OS.Range("A1") 'initilise la plage PL
For Each O In Sheets 'boucle 1 : sur tous les onlget O du classeur
    If Not O.Name = "SYNTHESE" Then 'condition 1 : si le nom de l'onglet n'est pas "SYNTHESE"
        TV = O.Range("A4").CurrentRegion 'définit le tableau des valeurs TV
        For I = 2 To UBound(TV, 1) 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
            If TV(I, 10) <> "Terminé" Then 'condition 2 : si la donnée ligne I colonne 10 de TV n'est pas égale à "Terminé"
                'redéfinit la plage PL comme (soit la ligne I des données, soit l'union de la plage PL et de la ligne I des données)
                If PL.Cells.Count = 1 Then Set PL = O.Cells(I + 3, "A").Resize(1, 10) Else Set PL = Application.Union(PL, O.Cells(I + 3, "A").Resize(1, 10))
            End If 'fin de la condition 2
        Next I 'prochaine ligne de la boucle 2
        Set DEST = OS.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST
        PL.Copy DEST 'copie la plage PL dans DEST
        Set PL = OS.Range("A1") 'réinitialise la plage PL
   End If 'fin de la condition 1
Next O 'prochaoine onglet de la boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

cdric78 · 7 Avril 2021

Robert à dit:

Bonjour Cédric, bonjour le forum,

Essaie comme ça :

VB:

Sub Synthèse()
Dim OS As Worksheet 'déclare la variable OS (Onglet Synthèse)
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim PL As Range 'déclare la variable PL (PLage)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set OS = Worksheets("SYNTHESE") 'définit l'onglet OS
DL = OS.Cells(Application.Rows.Count, "A").End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne A de l'onglet OS
Range("A5:K" & DL).ClearContents 'supprime les anciennes valeurs
Range("A5:K" & DL).Interior.ColorIndex = xlNone 'supprime les anciennes couleurs
Set PL = OS.Range("A1") 'initilise la plage PL
For Each O In Sheets 'boucle 1 : sur tous les onlget O du classeur
    If Not O.Name = "SYNTHESE" Then 'condition 1 : si le nom de l'onglet n'est pas "SYNTHESE"
        TV = O.Range("A4").CurrentRegion 'définit le tableau des valeurs TV
        For I = 2 To UBound(TV, 1) 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
            If TV(I, 10) <> "Terminé" Then 'condition 2 : si la donnée ligne I colonne 10 de TV n'est pas égale à "Terminé"
                'redéfinit la plage PL comme (soit la ligne I des données, soit l'union de la plage PL et de la ligne I des données)
                If PL.Cells.Count = 1 Then Set PL = O.Cells(I + 3, "A").Resize(1, 10) Else Set PL = Application.Union(PL, O.Cells(I + 3, "A").Resize(1, 10))
            End If 'fin de la condition 2
        Next I 'prochaine ligne de la boucle 2
        Set DEST = OS.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST
        PL.Copy DEST 'copie la plage PL dans DEST
        Set PL = OS.Range("A1") 'réinitialise la plage PL
   End If 'fin de la condition 1
Next O 'prochaoine onglet de la boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

Bonjour Robert,

Merci pour cette deuxième version

Cdric78

XL 2016 Macro synthèse de plusieurs onglets

cdric78

XLDnaute Junior

Pièces jointes

job75

job75

XLDnaute Barbatruc

Pièces jointes

cdric78

XLDnaute Junior

Robert

XLDnaute Barbatruc

cdric78

XLDnaute Junior

Discussions similaires