Fusion de lignes selon critère et date

Bonjour à toutes et à tous,

Voulant me simplifier une tâche quotidienne qui devient de plus en plus fastidieuse et ayant dans le passé manipulé quelques peu les macros VBA, je suis confronté à un problème que je vous explique:

Le fichier que vous trouverez en pièce jointe, présente différents types d'absences par individus (Matricule). Le traitement que je faisais jusqu'à maintenant manuellement est le suivant, les données bleutés signifient qu'elles ont déjà été recensées en interne, il faut donc les supprimer du fichier de la manière suivant cet exemple:

Avant traitement:

Groupe | Matricule | Motif Absence | Début | Fin

95A | 2017145 | RTT | 03/08/2015 | 07/08/2015

95A | 2017145 | RTT | 08/08/2015 | 09/08/2015

95A | 2017145 | RCN | 15/08/2015 | 16/08/2015

95A | 2017145 | CPT | 18/08/2015 | 21/08/2015

95A | 2017145 | CPT | 22/08/2015 | 23/08/2015

95A | 2017145 | CPT | 24/08/2015 | 28/08/2015

95A | 2017145 | CPT | 29/08/2015 | 30/08/2015

95A | 2017145 | CPT | 31/08/2015 | 31/08/2015

95A | 2017145 | CPT | 01/09/2015 | 04/09/2015

95A | 2017145 | CPT | 05/09/2015 | 06/09/2015

95A | 2017145 | CPT | 07/09/2015 | 07/09/2015

95A 2017145 | RTT | 01/08/2015 | 07/08/2015

95A 2017145 | CPT | 18/08/2015 | 31/08/2015

Après traitement:

Groupe | Matricule | Motif Absence | Début | Fin

95A | 2017145 | RTT | 08/08/2015 | 09/08/2015

95A | 2017145 | RCN | 15/08/2015 | 16/08/2015

95A | 2017145 | CPT | 01/09/2015 | 04/09/2015

95A | 2017145 | CPT | 05/09/2015 | 06/09/2015

95A | 2017145 | CPT | 07/09/2015 | 07/09/2015

Ainsi il ne me restera plus que ces données à faire remonter.

Pour les suppressions, comme dans l'exemple ci-dessus, il faut prendre en compte un matricule et un motif, et la suppression s'effectue sous la condition suivante, si mes données appartiennent à l'intervalle bleuté, il faut les supprimer ainsi que le dit intervalle.

Dit comme cela, ça paraît simple, mais après plus de 2 jours de prise de tête je viens quémander votre aide ...

Merci d'avance !

Bonjour

Un essai à tester.

Le temps d'exécution est un peu long : près de 4 mn sur mon PC.

A savoir la macro utilise les colonnes jusqu'à la colonne T.

Cela te convient-il ?

Bye !

Wow !

11 secondes d’exécution chez moi !

Ça me parait plus que parfait comme résultat, j'étais en train de me lancer dans l'étude de la fonction "DateDiff" mais je n'y comprenais pas grand chose ..

Tu viens de sauver pas mal d'heures de réflexion et de traitement, je t'en remercie gmb

Je peux dorénavant clore ce sujet, je t'envoie un mp pour plus d'informations et compréhension sur la macro.

Merci !

arkhang a écrit :

La 2ème feuille, a-t-elle une utilité dans l'exécution de la macro ?

Non, elle ne sert à rien. C'est une sauvegarde la feuille initiale que j'ai faite, pour ne pas perdre les objectifs.

Le 2ème module est-il appelé par la macro "Supprimer"?

Pas du tout.

C'est une macro que j'ai enregistrée pour retrouver la syntaxe exacte d'une fonction.

pourrais-tu m'expliquer brièvement le fonctionnement de la macro

La macro commence par une première étape qui consiste à établir une liste de jours continue en colonne H dont le départ est la date la plus ancienne de ta colonne D et qui se termine à la date la plus récente de cette même colonne.

Dans une deuxième étape, elle reporte ensuite sur les colonnes suivantes, en regard de la date indiquée en colonne H les indications relevées sur ton tableau pour toutes les lignes qui ont le même matricule, et s’il s’agit d’une ligne dont le texte est coloré, elle ajoute le motif d'abscence sur la colonne N (chose qu’elle ne fait pas pour les lignes non colorées).

Dans une troisième étape, toujours pour ce tableau établi pour un même matricule, elle repère dans toutes les lignes non vides les cellules qui se suivent avec les mêmes motifs d’absences et les mêmes date de départ et de fin et qui n'ont rien en cellule N et reporte une de ces lignes sur un 3° tableau, à la suite de celles qu'il peut déjà y avoir.

Lorsqu’elle trouve dans le tableau initial un nouveau matricule, elle efface les données qui concernent le matricule précédent dans le 2° tableau provisoire et recommence le même travail à partir de la deuxième étape.

Lorsqu’elle a traité ainsi le dernier matricule du tableau de départ, il ne lui reste plus qu’à supprimer les colonnes du deuxième tableau.

Le trosième tableau est celui qui contient le résultat.

OK ?

Bye !

Bonsoir gmb, arkhang, le forum

Exécute ces 2 macros successivement.

macro1 restitue en Feuil2 les lignes bleutées figurant en Feuil1, comme l'exemple illustré ci-dessous :

Lignes bleutées en Feuil1 :

Restitution des lignes bleutées en Feuil2 comme ceci :

Option Explicit
Sub macro1()
'Création d'une liste en feuil2 comme illustrée ci-dessus
Dim r As Range, rng As Range, ff As String, x As Range
Dim a, i As Long, w, txt As String, y, n As Long
    With Application.FindFormat
        .Clear
        .Font.ColorIndex = 5
    End With
    With Sheets("Feuil1")
        Set rng = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
        With rng
            Set r = .Find("*", searchformat:=True)
            If Not r Is Nothing Then
                ff = r.Address
                Do
                    If x Is Nothing Then
                        Set x = r.Resize(, 5)
                    Else
                        Set x = Union(x, r.Resize(, 5))
                    End If
                    Set r = .Find("*", r, searchformat:=True)
                Loop Until ff = r.Address
            End If
        End With
    End With
    With Sheets("Feuil2")
        .Cells.Clear
        x.Copy .Cells(1)
        With .Cells(1).CurrentRegion
            a = .Value
        End With
        With CreateObject("Scripting.Dictionary")
            For i = 1 To UBound(a, 1)
                txt = Join$(Array(a(i, 1), a(i, 2), a(i, 3)), Chr(2))
                If Not .exists(txt) Then
                    .Item(txt) = VBA.Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5))
                Else
                    w = .Item(txt)
                    If a(i, 4) < w(3) Then w(3) = a(i, 4)
                    If a(i, 5) > w(4) Then w(4) = a(i, 5)
                    .Item(txt) = w
                End If
            Next
            y = .items: n = .Count
        End With
        .Cells.Clear
        .Cells(1).Resize(n, 5).FormulaLocal = _
        Application.Index(y, 0, 0)
    End With
End Sub

macro2 s'appuie sur la liste créée en Feuil2 pour extraire les lignes de Feuil1.

Résultat final en Feuil3.

Sub macro2()
Dim a, b(), i As Long, j As Long, txt As String, n As Long
    a = Sheets("Feuil2").Cells(1).CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            txt = Join$(Array(a(i, 1), a(i, 2), a(i, 3)), Chr(2))
            .Item(txt) = VBA.Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5))
        Next
        a = Sheets("Feuil1").Cells(1).CurrentRegion.Value
        ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
        For i = 2 To UBound(a, 1)
            txt = Join$(Array(a(i, 1), a(i, 2), a(i, 3)), Chr(2))
            n = n + 1
            If Not .exists(txt) Then
                For j = 1 To UBound(a, 2)
                    b(n, j) = a(i, j)
                Next
            Else
                If a(i, 4) > .Item(txt)(4) Or a(i, 5) < .Item(txt)(3) Then
                    For j = 1 To UBound(a, 2)
                        b(n, j) = a(i, j)
                    Next
                Else
                    n = n - 1
                End If
            End If
        Next
    End With
    'Restitution en Feuil3
    With Sheets("Feuil3")
        .Cells.Clear
        If n > 0 Then
            .Cells(1).Resize(n, UBound(b, 2)).FormulaLocal = b
        Else
            MsgBox "Aucune donnée"
        End If
    End With
End Sub

Je n'obtiens pas du tout le même résultat que gmb, ai-je bien compris la question

Ou peut-être encore un problème de dates (inversion jours/mois) qui fausserait le résultat obtenu sur mon PC ?

klin89