Utiliser la même macro dans plusieurs feuilles

Le 03/02/2025 à 14:37

Bonjour à tous

Je suis novice en macrologie

Je récupère un classeur dont je ne suis ni le créateur ni le propriétaire. Ce classeur est alimenté par une quinzaine de personnes

Ce classeur contient plusieurs feuilles dont "lundi" "mardi" "mercredi" "jeudi" "vendredi" "samedi" "dimanche"

Chaque jour j'ai besoin de filtrer trois colonnes parmi onze colonnes existantes. Ensuite je les trie du plus petit au plus grand dans la colonne A. Enfin, je mets les doublons en surbrillance selon la colonne A

Ne maitrisant pas VBA j'ai utilisé l'enregistreur de macro. Je l'ai utilisé depuis la feuille appelée "Mercredi L1"

Voici mon problème : Si je lance ma macro en commençant par mercredi, puis les autres jours tout se déroule normalement

Si je lance la macro depuis un autre jour elle plante à la ligne ".Apply"

Si je recopie ma macro en remplaçant partout "mercredi L1" par un autre jour de la semaine, je peux la lancer dans la feuille correspondante, mais je ne trouve pas cela très propre... Sauriez-vous m'aider à n'avoir qu'une seule macro qui fonctionne avec toutes les feuilles ?

Ci dessous, la macro créée avec l'enregistreur de macro...

Merci d'avance pour votre aide

Sub Nettoyage_Synthese_Mercredi_L1()
'
' Nettoyage_Synthese Macro_Mercredi_L1
'
Range("A1").Select
Application.ScreenUpdating = False
Cells.Select
Selection.UnMerge
Rows("1:1").Select
Selection.Delete Shift:=xlUp
Cells.Select
Selection.EntireColumn.Hidden = False
Range("A:A,C:C,E:E,F:F,G:G,H:H,I:I,K:K,L:L,M:M,N:N,O:O,P:P,Q:Q,R:R,S:S,T:T"). _
Select
Range("T1").Activate
Selection.Delete Shift:=xlToLeft
Columns("A:A").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$A$414").AutoFilter Field:=1, Criteria1:="=Poste", _
Operator:=xlOr, Criteria2:="="
ActiveWindow.SmallScroll Down:=223
Cells.Select
Selection.Delete Shift:=xlUp
ActiveWorkbook.Worksheets("Mercredi L1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Mercredi L1").Sort.SortFields.Add2 Key:=Range( _
"A1:A414"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Mercredi L1").Sort
.SetRange Range("A1:U414")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns("A:A").Select
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
With Selection.FormatConditions(1).Font
.Color = -16383844
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Columns("C:C").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
Formula1:="=29"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.Color = -16383844
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("A1").Select
Dim s As Shape
For Each s In ActiveSheet.Shapes
s.Delete
Next
Application.ScreenUpdating = True
End Sub

8synthese-de-production-copie.zip (1.20 Mo)
Le 03/02/2025 à 14:42

Bonjour,

Bien sûr, mais pouvez-vous partager le classeur correspondant afin qu'on écrive la macro qui s'y adapte ? Merci.

Vous pouvez retirer/anonymiser les données de votre classeur bien entendu (en le gardant fonctionnel quand même). Ce qui compte c'est la structure.

Ah et utilisez le bouton </> pour insérer du code svp, beaucoup plus lisible.

Le 03/02/2025 à 14:42

bonjour Perceval983;

pouvez-vous aussi télécharger le fichier ou contient-il trop de données confidentielles ?

Le 03/02/2025 à 14:51

Le fichier contient beaucoup de données confidentielles

Néanmoins je vais essayer de le purger sans le corrompre, et je reviens le poster...

Le 03/02/2025 à 14:57

re, un premier essai, y-a-t-il des choses qui ne fonctionnent pas ?

Sub Nettoyage_Synthese_Mercredi_L1()

     Application.ScreenUpdating = False
     With ActiveSheet
          .Cells.UnMerge
          .Rows("1:1").Delete Shift:=xlUp
          .Cells.EntireColumn.Hidden = False
          .Range("A:A,C:C,E:E,F:F,G:G,H:H,I:I,K:K,L:L,M:M,N:N,O:O,P:P,Q:Q,R:R,S:S,T:T").Delete Shift:=xlToLeft
          On Error Resume Next

          .AutoFilter.Range.AutoFilter
          On Error GoTo 0
          .Range("$A$1:$A$414").AutoFilter Field:=1, Criteria1:="=Poste", Operator:=xlOr, Criteria2:="="
          '  .Cells.Delete Shift:=xlUp  '???? je ne sais pas ce qu'il doit se passer ici
          .Range("A1:U414").Sort .Range("A1"), xlAscending, Header:=xlNo
          .SetRange Range("A1:U414")

          With .Columns("A:A")
               .FormatConditions.AddUniqueValues
               .FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
               .FormatConditions(1).DupeUnique = xlDuplicate
               With .FormatConditions(1).Font
                    .Color = -16383844
                    .TintAndShade = 0
               End With
               With .FormatConditions(1).Interior
                    .PatternColorIndex = xlAutomatic
                    .Color = 13551615
                    .TintAndShade = 0
               End With
               .FormatConditions(1).StopIfTrue = False
          End With

          With .Columns("C:C")
               .FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, Formula1:="=29"
               .FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
               With .FormatConditions(1).Font
                    .Color = -16383844
                    .TintAndShade = 0
               End With
               With .FormatConditions(1).Interior
                    .PatternColorIndex = xlAutomatic
                    .Color = 13551615
                    .TintAndShade = 0
               End With
               .FormatConditions(1).StopIfTrue = False
          End With

          For Each s In .Shapes
               s.Delete
          Next
     End With
     Application.ScreenUpdating = True
End Sub
Le 03/02/2025 à 15:08

Voici mon fichier :-)

13synthese-de-production-copie.zip (1.20 Mo)
Le 03/02/2025 à 15:13

La ligne ".SetRange Range("A1:U414")" ne fonctionne pas...

Le 03/02/2025 à 15:27

il y a un mot de passe ?

sorry, je l'ai trouvé

Le 03/02/2025 à 15:57
pour le moment, encore sans le mot de passe (en état "unprotect")

Sub Nettoyage_Synthese_Lx()
     With ActiveSheet
          If .Name Like "* L#" Then          'nom de la feuille se termine avec un espace, un "L" et un chiffre

               With .Cells
                    .EntireColumn.AutoFit
                    .UnMerge
               End With

               .Rows(1).Delete
               .Columns("A:C").Insert Shift:=xlToRight
               .Columns("E:E").Copy .Range("A1")
               .Columns("G:G").Copy .Range("B1")
               .Columns("M:M").Copy .Range("C1")
               .Columns("D").Resize(, 100).Delete Shift:=xlToLeft

               With .Range("A1").Resize(500, 3)
                    .Sort .Range("A1"), xlAscending, Header:=xlYes
                    .AutoFilter 1, "Poste*", xlOr, "="
                    Application.DisplayAlerts = False
                    .Offset(1).SpecialCells(xlVisible).Delete
                    Application.DisplayAlerts = True
                    .AutoFilter
                    .EntireColumn.AutoFit
               End With
          Else
               MsgBox "nom de la feuille est faux"
          End If

          For Each shp In .Shapes
               shp.Delete
          Next

     End With
End Sub
Le 03/02/2025 à 16:10

et avec MFC

Sub Nettoyage_Synthese_Lx()
     With ActiveSheet
          If .Name Like "* L#" Then          'nom de la feuille se termine avec un espace, un "L" et un chiffre

               With .Cells
                    .EntireColumn.AutoFit
                    .UnMerge
               End With

               .Rows(1).Delete
               .Columns("A:C").Insert Shift:=xlToRight
               .Columns("E:E").Copy .Range("A1")
               .Columns("G:G").Copy .Range("B1")
               .Columns("M:M").Copy .Range("C1")
               .Columns("D").Resize(, 100).Delete Shift:=xlToLeft

               With .Range("A1").Resize(500, 3)
                    .Sort .Range("A1"), xlAscending, Header:=xlYes
                    .AutoFilter 1, "Poste*", xlOr, "="
                    Application.DisplayAlerts = False
                    .Offset(1).SpecialCells(xlVisible).Delete
                    Application.DisplayAlerts = True
                    .AutoFilter
                    .EntireColumn.AutoFit

                    With .Offset(1).Columns(1)
                         .FormatConditions.AddUniqueValues
                         .FormatConditions(1).DupeUnique = xlDuplicate
                         .FormatConditions(1).Interior.Color = 16738047
                    End With

                    With .Offset(1).Columns(3)
                         .FormatConditions.Add Type:=xlExpression, Formula1:="=C2>29"
                         .FormatConditions(1).Interior.Color = 13395711
                    End With
               End With
          Else
               MsgBox "nom de la feuille est faux"
          End If

          For Each shp In .Shapes
               shp.Delete
          Next

     End With
End Sub
Le 03/02/2025 à 16:26

Cela semble fonctionner

Je ferais plus de tests demain, en attendant je te remercie pour ton aide :-)

Rechercher des sujets similaires à "utiliser meme macro feuilles"