Recherche les cellules remplies & lignes liées

Private Sub Worksheet_Change(ByVal Target As Range)
Dim dest As Range, d As Object, t, i&, n&, resu(), j%
Set dest = [G5] '1ère cellule de destination, à adapter
t = [A4].CurrentRegion.Resize(, 5) 'matrice, plus rapide
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 2 To UBound(t)
    If t(i, 5) <> "" Then d(t(i, 2)) = "" 'liste des clients des récidives
Next
Application.EnableEvents = False 'désactive les évènemnts
If d.Count Then
    For i = 2 To UBound(t)
        If d.exists(t(i, 2)) Then
            n = n + 1
            ReDim Preserve resu(1 To 5, 1 To n)
            For j = 1 To 5
                resu(j, n) = t(i, j)
            Next j
        End If
    Next i
    '---transposition---
    For i = 1 To n
        For j = 1 To 5
            t(i, j) = resu(j, i)
    Next j, i
    '---restitution---
    If FilterMode Then ShowAllData 'si la feuille est filtrée
    dest.Resize(n, 5) = t
End If
dest(n + 1).Resize(Rows.Count - n - dest.Row + 1, 5).ClearContents 'RAZ sous le tableau
Application.EnableEvents = True 'réactive les évènemnts
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub