Microsoft 365 "Fusion de lignes" selon multicritères

[Matt_Le_blond]

Bonsoir à tous,

Je sollicite votre aide sur un cas qui me turlupine

J'ai différentes personnes qui ont chacun un nom / un lieu / un métier puis une date début et fin de présence.
Parfois j'ai plusieurs lignes consécutives avec tous les trois 1ers critères identiques mais cela se passe le lendemain.

J'aimerai fusionner les lignes qui ont les critères identiques avec des dates successives en une seule ligne (ex en pièce jointe) et là je bloque...

Merci d'avance à ceux qui se pencheront sur mon cas
Matt

 

[job75]

Bonsoir Matt_Le_blond, bienvenue sur XLD,

Comme le tableau peut être grand, il faut mettre le résultat dans une autre feuille.

Voyez le fichier joint et cette macro dans la feuille "Résultat" :

Private Sub Worksheet_Activate()
Dim d As Object, a(), tablo, i&, x$, n&, j%, lig&
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
ReDim a(1 To Rows.Count, 1 To 5)
tablo = [Tableau1].Resize(, 5) 'matrice, plus rapide
For i = 1 To UBound(tablo)
    x = tablo(i, 1) & Chr(1) & tablo(i, 2) & Chr(1) & tablo(i, 3)
    If Not d.exists(x) Then
        n = n + 1
        d(x) = n 'mémorise la ligne
        For j = 1 To 5
            a(n, j) = tablo(i, j)
        Next j
    End If
    lig = d(x) 'récupère la ligne
    If tablo(i, 4) < a(lig, 4) Then a(lig, 4) = tablo(i, 4)
    If tablo(i, 5) > a(lig, 5) Then a(lig, 5) = tablo(i, 5)
Next i
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] '1ère cellule de destination, à adapter
    If n Then
        .Resize(n, 5) = a
        .Resize(n, 5).Borders.Weight = xlThin 'bordures
    End If
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 5).Delete xlUp 'RAZ en dessous
End With
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Elle se déclenche quand on active la feuille.

Il est tout à fait inutile de mettre le tableau du résultat sous forme de tableau structuré.

A+

 

[Matt_Le_blond]

Bonjour Job75,

mille mercis de t'être penché sur mon problème et pour cette super proposition !
La macro est super rapide et son application juste en sélectionnant le 2e onglet c'est Whaou !!!

- J'aurai besoin d'une petite modif car j'ai peut être mal spécifié mon besoin : la fusion de 2 lignes (ou +) doit se faire uniquement si les 3 critères de mon exemple sont identiques ET la date de début = le lendemain de la ligne au-dessus.
Si l'espace entre les 2 date est supérieur alors il n'y a pas de fusion.

Dans mon tableau exemple : si les 3 lignes "Papa" sont des jours début successifs (5, 6 et 7 juin) = on fusionne, si le 3e jour est le 8 juin, seules les 2 premières lignes fusionnent.

- Autre question : mon "vrai" tableau comporte davantage de colonnes que celui-ci et les dates sont au milieu de celles-ci. Quels seront les critères à modifier dans la macro pour adapter ton travail à mon besoin ?

Merci encore pour ton aide

 

[job75]

Bonjour Matt_Le_blond,

Avec la contrainte des dates qui se suivent c'est plus compliqué.

Dans ce fichier (2) je n'utilise plus le Dictionary mais des tris sur le tableau source :

Private Sub Worksheet_Activate()
Dim tablo, i&, n&, j%
With [Tableau1]
    .Columns(6).Resize(, 2).EntireColumn.Insert 'insère 2 colonnes auxiliaires à la fin
    .Columns(6) = "=RC[-5]&CHAR(1)&RC[-4]&CHAR(1)&RC[-3]" 'concaténation
    .Cells(1, 7) = 1: .Columns(7).DataSeries 'numérotation
    .Sort .Columns(4), xlAscending, Header:=xlYes 'tri sur la date de début
    tablo = Union(.Rows(0), .Cells).Resize(, 6) 'matrice, plus rapide, avec ligne des titres
    .Sort .Columns(7), xlAscending, Header:=xlYes 'tri dans l'ordre initial
    .Columns(6).Resize(, 2).EntireColumn.Delete 'supprime les 2 colonnes auxiliaires
End With
ReDim resu(1 To UBound(tablo), 1 To 5)
For i = 2 To UBound(tablo)
    If UCase(tablo(i, 6)) <> UCase(tablo(i - 1, 6)) Or Int(Val(tablo(i, 4))) <> Int(Val(tablo(i - 1, 4))) + 1 Then
        n = n + 1
        For j = 1 To 4
            resu(n, j) = tablo(i, j)
        Next j
    End If
    resu(n, 5) = tablo(i, 5)
Next i
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] '1ère cellule de destination, à adapter
    If n Then
        .Resize(n, 5) = resu
        .Resize(n, 5).Borders.Weight = xlThin 'bordures
    End If
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 5).Delete xlUp 'RAZ en dessous
End With
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Si le tableau a plus de 5 colonnes déposez ici votre fichier allégé et sans données confidentielles.

A+

 

[Matt_Le_blond]

Job75 tu es épatant !!! C'est tout à fait ça !!!

Mon fichier définitif est en cours de réalisation.
Je ne voudrais pas te solliciter 50 fois donc, si tu es toujours partant pour m'aider, je reviendrai vers toi dès que ma feuille sera définitive

Bon week-end

 

[chris]

Bonjour à tous

Une solution PowerQuery (intégré à Excel 2016+)

Mise à jour par Données, Actualiser tout ou une ligne de VBA à l'activation

Private Sub Worksheet_Activate()

ThisWorkbook.RefreshAll

End Sub

 

[Matt_Le_blond]

Bonjour à tous

Une solution PowerQuery (intégré à Excel 2016+)

Mise à jour par Données, Actualiser tout ou une ligne de VBA à l'activation

Private Sub Worksheet_Activate()

ThisWorkbook.RefreshAll

End Sub

Merci Chris. Très intéressante cette approche.
J'ai hâte de finaliser mon tableau pour avancer plus loin encore.

Bon dimanche !