XL 2016 Boucle avec tri par date sur onglets

Aldonanou · 27 Novembre 2022

Bonjour,

Afin d'alléger une macro, j'aimerai automatiser le tri effectué sur chaque Ws par une boucle. En effet, le "programme" dure 15 minutes ce qui exaspère mes collègues !

Malgré le fait que je définisse la Ws en précisant les onglets sur lesquels l'action doit être effectuée, cela me met un message d'erreur justement sur la Ws. Il s'agit des 10 premiers onglets de ce Workbook.

Il doit certainement manquer quelque chose.

Quelqu'un pourrait m'aider.

Merci

[/CODE]

' Périodes quadrimestres
DateDebQ1 = #3/1/2022#
DateFinQ1 = #4/30/2022#
DateDebQ2 = #2/5/2022#
DateFinQ2 = #8/27/2022#
DateDebQ3 = #8/29/2022#
DateFinQ3 = #12/31/2022#

For Each Ws In ActiveWorkbook.Worksheets(Array("voiture", "camion", "avion", "train", "bateau", "vélo", "moto", "trottinette", "voiturette", "paquebot"))

If DateExtraction <= DateFinQ1 Then
With Worksheets(Ws)
With .Range("A1:AA" & Cells(.Rows.Count, "R").End(xlUp).Row)
[A1].AutoFilter field:=1, _
Criteria1:=">=" & Format(DateDebQ1, "mm/dd/yy"), Operator:=xlAnd, _
Criteria2:="<=" & Format(DateFinQ1, "mm/dd/yy")
End With
End With

Else

If DateExtraction > DateDebQ2 And DateExtraction <= DateFinQ2 Then
With Worksheets(Ws)
With .Range("A1:AA" & Cells(.Rows.Count, "R").End(xlUp).Row)
[A1].AutoFilter field:=1, _
Criteria1:=">=" & Format(DateDebQ2, "mm/dd/yy"), Operator:=xlAnd, _
Criteria2:="<=" & Format(DateFinQ2, "mm/dd/yy")
End With
End With

Else

If DateExtraction > DateDebQ3 And DateExtraction <= DateFinQ3 Then
With Worksheets(Ws)
With .Range("A1:AA" & Cells(.Rows.Count, "R").End(xlUp).Row)
[A1].AutoFilter field:=1, _
Criteria1:=">=" & Format(DateDebQ3, "mm/dd/yy"), Operator:=xlAnd, _
Criteria2:="<=" & Format(DateFinQ3, "mm/dd/yy")
End With
End With
End If

End If

End If

Next Ws

End Sub

Hasco · 27 Novembre 2022

Bonjour

Il s'agit de Filtrage automatique pas de Tri.
Quel est l'intérêt de filtrer autant de feuilles en même temps ? Impression ?
Vous les consultez toutes ensembles, d'un seul coup d'oeil ?
Pourquoi ne pas faire ça sur activation d'une feuille.

On ne connait rien des tenants et aboutissants de votre macro ni même par quoi elle est lancée, alors on ne peut que dire des choses bateaux, avec n chances de tomber juste sur ce qui fait problème.

Y-aurait-il ? des instructions dans les évènements Change des feuilles ?
Auquel cas ajouter en début de macro

Application.EnableEvents = False

et

Application.EnableEvents = True

en fin de macro

Déjà et même si cela n'arrange pas le temps d'exécution de votre macro voici une façon possible d'écrire vos choix de dates et constructions de critères :

VB:

    Select Case DateExtraction

    Case DateDebQ1 To DateFinQ1
        D1 = DateDebQ1
        D2 = DateFinQ1

    Case DateDebQ2 To DateFinQ2
        D1 = DateDebQ2
        D2 = DateFinQ2

    Case DateDebQ3 To DateFinQ3
        D1 = DateDebQ3
        D2 = DateFinQ3

    End Select

    If D1 > 0 And D2 > 0 Then
        With ws.Range("A1:AA" & ws.Cells(Rows.Count, "R").End(xlUp).Row)
            .AutoFilter field:=1, Criteria1:=">=" & Format(D1, "mm/dd/yy"), _
                        Operator:=xlAnd, Criteria2:="<=" & Format(D2, "mm/dd/yy")
        End With
        D1 = 0 : D2 = 0
    End If

Vous pouvez également écrire :
Ws.Range("A1").CurrentRegion.AutoFilter ......

s'il n'y a pas de colonnes vides entre A et AA ni de ligne vides dans le tableau
"
Pour publier vos codes si vous pouviez utilisez le bouton "<>" en haut de l'éditeur de post, ce serait plus lisible pour tout le monde.

mapomme · 27 Novembre 2022

Bonjour @Hasco

,

VB:

If D1 > 0 And D2 > 0 Then
        With ws.Range("A1:AA" & ws.Cells(Rows.Count, "R").End(xlUp).Row)
            .AutoFilter field:=1, Criteria1:=">=" & Format(D1, "mm/dd/yy"), _
                        Operator:=xlAnd, Criteria2:="<=" & Format(D2, "mm/dd/yy")
        End With

Avant de filtrer, ne faudrait-il pas insérer l’instruction : If ws.FilterMode then ws.ShowAllData ?

Si la feuille ws est déjà filtrée, on risque que End(xlUp).Row ne retourne pas la bonne ligne (si les dernières lignes sont masquées par le filtre), non ?

Hasco · 27 Novembre 2022

hello @mapomme

Sans doute si ; tu as raison.
Il y a longtemps que je ne réfléchis plus à la place des gens et que je fait mes réponses à la hauteur des questions, pas plus. Et que je ne donne pas plus que ce qu'ils donnent (du moins j'essaie)

Encore là j'ai fais l'effort de mettre le code entre les balises idoines. J'aurais pas dû.

Bonne journée à toi

Aldonanou · 27 Novembre 2022

Bonjour,

Merci à Hasco et mapomme pour vos réponses.

Je suis novice en VBA (entièrement autodidacte), et j'essaie toujours de faire au mieux les choses, je ne demande qu'à apprendre.

Hasco, je comprends votre frustration mais si j'avais sur comment "Encore là j'ai fais l'effort de mettre le code entre les balises idoines. J'aurais pas dû." cela aurait été fait.

Hasco à dit:
Bonjour

Il s'agit de Filtrage automatique pas de Tri.
Quel est l'intérêt de filtrer autant de feuilles en même temps ? Impression ?
Vous les consultez toutes ensembles, d'un seul coup d'oeil ?
Pourquoi ne pas faire ça sur activation d'une feuille.

On ne connait rien des tenants et aboutissants de votre macro ni même par quoi elle est lancée, alors on ne peut que dire des choses bateaux, avec n chances de tomber juste sur ce qui fait problème.

Y-aurait-il ? des instructions dans les évènements Change des feuilles ?
Auquel cas ajouter en début de macro

et

en fin de macro

Déjà et même si cela n'arrange pas le temps d'exécution de votre macro voici une façon possible d'écrire vos choix de dates et constructions de critères :

VB:

Select Case DateExtraction Case DateDebQ1 To DateFinQ1 D1 = DateDebQ1 D2 = DateFinQ1 Case DateDebQ2 To DateFinQ2 D1 = DateDebQ2 D2 = DateFinQ2 Case DateDebQ3 To DateFinQ3 D1 = DateDebQ3 D2 = DateFinQ3 End Select If D1 > 0 And D2 > 0 Then With ws.Range("A1:AA" & ws.Cells(Rows.Count, "R").End(xlUp).Row) .AutoFilter field:=1, Criteria1:=">=" & Format(D1, "mm/dd/yy"), _ Operator:=xlAnd, Criteria2:="<=" & Format(D2, "mm/dd/yy") End With D1 = 0 : D2 = 0 End If

Vous pouvez également écrire :
Ws.Range("A1").CurrentRegion.AutoFilter ......

s'il n'y a pas de colonnes vides entre A et AA ni de ligne vides dans le tableau
"
Pour publier vos codes si vous pouviez utilisez le bouton "<>" en haut de l'éditeur de post, ce serait plus lisible pour tout le monde.

J'ai réalisé trois formulaires dans deux fichiers séparés qui ont été déployé sur 10 répertoires distincts.

Puis j'ai créé un menu de pilotage me permettant de récupérer les données saisies dans les trois formulaires des 10 répertoires et d'en faire une analyse pour une restitution dans des tableaux.

Toutes les semaines le vendredi après-midi à 15:00 se déclenche automatiquement le lancement des différentes macros avec in fine la transmission de courriels avec les tableaux joints.

Les périodes d'analyse s'effectuent sur de l'annuel, de l'hebdomadaire et du quadrimestre.

Mon programme va donc répéter pour les 10 sites, une fois chaque formulaire importé dans 3 fichiers distincts, les mêmes choses : production annuelle, production hebdomadaire et production du quadrimestre.

Le filtrage par feuille me permet de faire des calculs pour chaque période créée pour cette occasion (feuille temporaire).

Je vais déjà faire le nécessaire grâce à vos astuces fournies.

Ce que j'aimerai faire c'est pouvoir automatiser l'action sur les 10 onglets en fonction de la période de sélection sans avoir à l'écrire pour chaque site via une boucle. Je précise que le programme que j'ai écrit fonctionne mais qu'il y doit certainement avoir une possibilité de l'alléger.

' Enlève les filtres
'Dim Ws As Worksheet
For Each Ws In ActiveWorkbook.Worksheets(Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "10"))
If Ws.AutoFilterMode = True Then
Ws.AutoFilterMode = False
End If
Next Ws

' Lancement réalisation TCD
Application.ScreenUpdating = False
Set Wb = ActiveWorkbook

For Each Ws In Wb.Worksheets
For Each pt In Ws.PivotTables
pt.TableRange2.Delete
Next pt
Next Ws

lRow = 1
ptCount = 1

For Each Ws In Wb.Worksheets(Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "10"))

lastRow = Ws.Cells(Rows.Count, "AB").End(xlUp).Row
lastCol = Ws.Cells(lRow, Columns.Count).End(xlToLeft).Column

Set rngPt = Ws.Cells(lRow, 1).Resize(lastRow, lastCol)
Set ptCache = Wb.PivotCaches.Create(xlDatabase, rngPt, 4) '4
Set pt = ptCache.CreatePivotTable(Ws.Cells(lRow, lastCol + 2), "TCD " & ptCount, , 4)

pt.ManualUpdate = True
'Colonne
pt.AddFields _
RowFields:=Array("")

'Ligne
With pt.PivotFields("")
.Orientation = xlDataField
.Function = xlSum
.Position = 1
.NumberFormat = "#,##0"
.Caption = "Somme de "
End With

With pt.PivotFields(" ")
.Orientation = xlDataField
.Function = xlSum
.Position = 2
.NumberFormat = "#,##0"
.Caption = "Somme de F"
End With

suite avec la création d'un nouvel onglet

' Colonnes items
Range("A1").Value = ""
Range("B1").Value = ""
Range("C1").Value = " "
Range("D1").Value = ""
Range("E1").Value = " "
Range("F1").Value = " "
Range("G1").Value = " "
Range("H1").Value = " "

Columns("A:A").EntireColumn.AutoFit

Sheets("1").Select
Range("AD2:AK2").CurrentRegion.Copy
Sheets("R_CICTC").Select
DerLig = Cells(Rows.Count, 1).End(xlUp).Row
Range("A" & DerLig + 1).Select
ActiveSheet.Paste

Sheets("2").Select
Range("AD2:AK2").CurrentRegion.Copy
Sheets("R_CICTC").Select
DerLig = Cells(Rows.Count, 1).End(xlUp).Row
Range("A" & DerLig + 1).Select
ActiveSheet.Paste

Sheets("3").Select
Range("AD2:AK2").CurrentRegion.Copy
Sheets("R_CICTC").Select
DerLig = Cells(Rows.Count, 1).End(xlUp).Row
Range("A" & DerLig + 1).Select
ActiveSheet.Paste

Merci beaucoup.

Hasco · 28 Novembre 2022

bonjour,

Où l'on voit que coder ne s'invente pas.

Pourquoi faire une boucle pour chaque action ?

vous pourriez sans doute :

VB:

Option Explicit

Dim Ws As Worksheet
Dim Wb As Workbook

Set Wb = ActiveWorkbook
Application.ScreenUpdating = False

'boucle sur toutes les feuilles du classeurs
For Each Ws In Wb.Worksheets
    '
    ' Action sur toutes les feuilles
    If Ws.AutoFilterMode = True Then Ws.AutoFilterMode = False


    ' Action uniquement sur les feuilles nommées "1" à "10"
    ' Trouvera "1" dans "10" mais pas "11" ou "12"
    If InStr("2,3,4,5,6,7,8,9,10", Ws.Name) Then

        ' S'il n'y a pas de PivotTables dans la feuille
        ' la boucle ne sera pas exécutée
        For Each pt In Ws.PivotTables
            pt.TableRange2.Delete
        Next

        'Création des TCD
    End If
Next Ws

Ou avoir un module avec un macro principale qui appelle vos macros secondaires dans une seule boucle :

Code:

Sub Main()


    Dim Ws As Worksheet
    Dim Wb As Workbook

    Set Wb = ActiveWorkbook
    Application.ScreenUpdating = False

    'boucle sur toutes les feuilles du classeurs
    For Each Ws In Wb.Worksheets
        '
        ' Appel à la macro de filtrage
        MacroFiltrage Ws
        '
        ' Si feuille nommées de "1" à "10" alors créer TCD
        If InStr("2,3,4,5,6,7,8,9,10", Ws.Name) Then CreationTCD

    Next Ws
    '
    Application.ScreenUpdating = True
End Sub

Sub MacroFiltrage(Feuille As Worksheet)
    With Feuille
        If .AutoFilterMode = True Then .AutoFilterMode = False

        ' instructions de filtrage

    End With
    '
    ' retour à la macro appelante
End Sub

Sub CreationTCD(Feuille As Worksheet)
    With Feuille
        For Each pt In .PivotTables
            pt.TableRange2.Delete
        Next
        '...suite de la création de tcd
    End With
    '
    ' retour à la macro appelante
End Sub

Je ne vois pas quoi vous dire d'autre, ne connaissant toujours pas vos macros,
Si, sans doute que vous tireriez avantage à utiliser PowerQuery. Pour vos actions de filtrage et TCD
Mais là....

Aldonanou · 28 Novembre 2022

Bonjour Hasco, merci pour votre aide. J'ai déjà pu adapter mes macros grâce à vos précisions. C'est génial.

Effectuez une recherche sur Excel Downloads...

XL 2016 Boucle avec tri par date sur onglets

Aldonanou

XLDnaute Junior

Hasco

Hasco

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

Hasco

XLDnaute Barbatruc

Aldonanou

XLDnaute Junior

Hasco

XLDnaute Barbatruc

Aldonanou

XLDnaute Junior

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums