Suppression Lignes automatique avec multiples conditions

Bonjour à tous,

Voila, je vous expose ma problématique :

J'effectue quotidiennement un travail répétitif sur un tableau Excel (qui m'est transmis par un intermédiaire) qui me prend un temps fou et qui j'en suis certain pourrait être grandement simplifié et ainsi me laisserait plus de temps pour me consacrer à d'autres tâches.

Ce que je dois faire sur ce tableau :

• Le tableau que je reçois recense une liste de magasins dont je suis gestionnaire et pour lesquelles je dois effectuer un tri en fonction de divers événements.
• Les éléments qui composent ce tableau sont : le nom du magasin, l'évènement qui s'est produit, la date et l'heure à laquelle s'est produit l'événement.
• Sur ce tableau je dois faire en sorte de ne garder QUE les lignes (donc les magasins) pour lesquelles deux événements DIFFERENTS ont eu lieu en moins de 15 minutes. Toutes les lignes sur lesquelles chaque évènements sont espacés de plus de 15 minutes pour un même magasin doivent être supprimées, de même pour les magasins n'ayant eu qu'un seul évènement en tout. J'espère que c'est clair

Il faut savoir que je fais actuellement ce travail manuellement et que ce tableau peut parfois être composé de plusieurs centaines, voir de miliers de lignes par jour, d'où le temps fou que j'y consacre quotidiennement.

Mon objectif aujourd'hui est de faire appel à vous afin de savoir si cette tâche pourrait être simplifiée, voir automatisée, et si oui de quelle manière ? Avez-vous des solutions ou des exemples à me proposer ? Car je ne sais pas du tout comment faire ...

Afin que cela soit plus clair, je joins ci dessous un exemple fictif de ce que je reçois et ce que je dois obtenir à la fin.

Exemple fichier reçu :

Exemple fichier fini :

Je vous remercie par avance et espère que quelqu'un saura m'apporter une solution

Bonsoir,

Une procédure à tester :

Sub EpurerEvènements()
    Dim Ev(), dt, n&, i&, j&, k%, Evec As Boolean
    With ActiveSheet
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Range("A1").Resize(n, 3).Sort key1:=.Range("A1"), order1:=xlAscending, _
          key2:=.Range("C1"), order2:=xlAscending, Header:=xlYes
        ReDim Ev(1 To 3, 1 To 1): Evec = True: j = 1
        For k = 1 To 3
            Ev(k, 1) = .Cells(1, k)
        Next k
        For i = 3 To n
            If .Cells(i, 1) = .Cells(i - 1, 1) Then
                dt = (.Cells(i, 3) - .Cells(i - 1, 3)) * 1440
                If dt <= 15 Then
                    If Evec Then
                        j = j + 2: ReDim Preserve Ev(1 To 3, 1 To j): Evec = False
                        For k = 1 To 3
                            Ev(k, j - 1) = .Cells(i - 1, k)
                        Next k
                    Else
                        j = j + 1: ReDim Preserve Ev(1 To 3, 1 To j)
                    End If
                    For k = 1 To 3
                        Ev(k, j) = .Cells(i, k)
                    Next k
                Else
                    Evec = True
                End If
            End If
        Next i
    End With
    Application.ScreenUpdating = False
    ActiveSheet.Copy before:=Worksheets(1)
    With ActiveSheet
        .Range("A1").Resize(n, 3).ClearContents
        .Range("A1").Resize(j, 3).Value = WorksheetFunction.Transpose(Ev)
        .Shapes("Bouton 1").Delete
    End With
    Application.ScreenUpdating = True
End Sub

Cordialement.

Merci beaucoup MFERRAND, cela fonctionne parfaitement sur le tableau qui sert d'exemple, c'est exactement ce que je cherchais !!

Cependant, je viens de tester sur mon tableau originale et ce la ne fonctionne pas ( ceci surement dû au fait qu'il y a d'avantage de colonnes dans le tableau original), et je n'arrive pas à voir ce qu'il faut modifier dans la macro pour que cela fonctionne ...

Si je joins juste l'entête de mon tableau original ( donc sans aucune donné ), est-il possible que tu me dise ou me montre ce que je dois modifier pour que cela fonctionne ? Ce serait très sympa ...

Entête Tableau :

Merci par avance pour aide précieuse,

Cordialement

On perd du temps avec des modèles dont la structure ne respecte pas l'original !

On passe de 3 à 7 colonnes. Nom magasin = col. 3. Dateheure = col.7.

On va essayer de rectifier au pied levé :

Sub EpurerEvènements()
    Dim Ev(), dt, n&, i&, j&, k%, Evec As Boolean
    With ActiveSheet
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Range("A1").Resize(n, 7).Sort key1:=.Range("C1"), order1:=xlAscending, _
          key2:=.Range("G1"), order2:=xlAscending, Header:=xlYes
        ReDim Ev(1 To 7, 1 To 1): Evec = True: j = 1
        For k = 1 To 7
            Ev(k, 1) = .Cells(1, k)
        Next k
        For i = 3 To n
            If .Cells(i, 3) = .Cells(i - 1, 3) Then
                dt = (.Cells(i, 7) - .Cells(i - 1, 7)) * 1440
                If dt <= 15 Then
                    If Evec Then
                        j = j + 2: ReDim Preserve Ev(1 To 7, 1 To j): Evec = False
                        For k = 1 To 7
                            Ev(k, j - 1) = .Cells(i - 1, k)
                        Next k
                    Else
                        j = j + 1: ReDim Preserve Ev(1 To 7, 1 To j)
                    End If
                    For k = 1 To 7
                        Ev(k, j) = .Cells(i, k)
                    Next k
                Else
                    Evec = True
                End If
            End If
        Next i
    End With
    Application.ScreenUpdating = False
    ActiveSheet.Copy before:=Worksheets(1)
    With ActiveSheet
        .Range("A1").Resize(n, 7).ClearContents
        .Range("A1").Resize(j, 7).Value = WorksheetFunction.Transpose(Ev)
        .Shapes("Bouton 1").Delete
    End With
    Application.ScreenUpdating = True
End Sub

Voilà ! Si je n'ai rien loupé, cela devrait être bon.

Alors cette fois ci c'est assez étrange, car le premier exemple fonctionnait très bien sur le fichier test, mais en intégrant le nouveau code à mon fichier d'origine je n'ai pas la même réaction, voici le détail de ce qui se passe :

- Lorsque qu'un magasin déclenche seulement 2 événements en tout et qu'ils sont différents mais ont lieu en moins de 15 mn, le module me supprime un des 2 événements alors que cela ne devrait pas être le cas, il devrait me garder ces deux événements.

- Certains événement identiques ayant lieu en moins de 15 mn pour un même magasin sont conservés alors que cela ne devrait pas être le cas , au moins un d'eux devrait être supprimé si le magasin a déclenché plus de 2 Evénements, et les deux devraient être supprimés s'il n'a déclenché que deux événements.

Voila ce que j'ai pu constater ... Avez-vous une autre idée de ce qui peut poser problème ? Vraiment désolé d'en demander autant mais je ne vois vraiment pas ou est l’erreur ..

Je vous joins un nouveau fichier Exemple fictif sur lequel j'ai appliqué le code pour que vous vous rendiez compte de ce qui ne vas pas.

Merci

Je vérifierai dans la soirée... Je viens de voir que zappé le test sur évènements différents, j'en profiterai pour rectifier ça !

A+

Merci énormément pour votre aide en tout cas, je commençais à désespérer pouvoir arriver à un résultat un jour ...

Bonsoir,

Le problème est que ton fichier ne contient aucune donnée (et aucun code), donc je ne peux rien constater, en repassant au crible la dernière macro, celle-ci utilise une variable booléenne qui est à True lorsque 2 évènements sont à lister, et à False s'il n'y en a qu'une. Lorsqu'on entamait une suite d'évènements à retenir, la valeur était basculée à False, et rétablie à True lorsqu'on rencontrait un écart supérieur à 15 minutes. Il y avait donc une possibilité qu'un changement de magasin intervienne alors que la valeur était à False, entrainant le rejet de l'évènement antérieur... J'apporte un correctif.

Pour l'élimination de la répétition du même évènement, comme je l'ai dit, j'ai vu que j'avais zappé la condition, je l'introduis en même temps que la vérification qu'on est dans le même magasin...

La macro modifiée : les ajouts sont surlignés.

Sub EpurerEvènements()
    Dim Ev(), dt, n&, i&, j&, k%, Evec As Boolean
    With ActiveSheet
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Range("A1").Resize(n, 7).Sort key1:=.Range("C1"), order1:=xlAscending, _
          key2:=.Range("G1"), order2:=xlAscending, Header:=xlYes
        ReDim Ev(1 To 7, 1 To 1): Evec = True: j = 1
        For k = 1 To 7
            Ev(k, 1) = .Cells(1, k)
        Next k
        For i = 3 To n
            If .Cells(i, 3) = .Cells(i - 1, 3) And .Cells(i, 6) <> .Cells(i - 1, 6) Then
                dt = (.Cells(i, 7) - .Cells(i - 1, 7)) * 1440
                If dt <= 15 Then
                    If Evec Then
                        j = j + 2: ReDim Preserve Ev(1 To 7, 1 To j): Evec = False
                        For k = 1 To 7
                            Ev(k, j - 1) = .Cells(i - 1, k)
                        Next k
                    Else
                        j = j + 1: ReDim Preserve Ev(1 To 7, 1 To j)
                    End If
                    For k = 1 To 7
                        Ev(k, j) = .Cells(i, k)
                    Next k
                Else
                    Evec = True
                End If
            Else
                Evec = True
            End If
        Next i
    End With
    Application.ScreenUpdating = False
    ActiveSheet.Copy before:=Worksheets(1)
    With ActiveSheet
        .Range("A1").Resize(n, 7).ClearContents
        .Range("A1").Resize(j, 7).Value = WorksheetFunction.Transpose(Ev)
        .Shapes("Bouton 1").Delete
    End With
    Application.ScreenUpdating = True
End Sub