XL 2016 Macro synthèse de plusieurs onglets

  • Initiateur de la discussion Initiateur de la discussion cdric78
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

cdric78

XLDnaute Junior
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
 

Pièces jointes

Solution
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+
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+
 

Pièces jointes

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 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
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

  • Question Question
Microsoft 365 macro vba sumifs
Réponses
5
Affichages
629
Retour