[RESOLU] Extraction doublon ligne dans plage

Private Sub CommandButton1_Click() 'bouton Doublons
Dim ta, ncol%, tb(), d As Object, i&, x$, n&, j%
ta = [T] 'matrice, plus rapide
ncol = UBound(ta, 2)
ReDim tb(1 To UBound(ta), 1 To ncol)
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(ta)
  x = ta(i, 6) & " " & ta(i, 7) & " " & ta(i, 8) & " " & ta(i, 9) & " " & ta(i, 10)
  If d.exists(x) Then
    n = n + 1
    If ta(d(x), 1) <> Chr(1) Then
      For j = 1 To ncol
        tb(n, j) = ta(d(x), j)
      Next j
      ta(d(x), 1) = Chr(1) 'repérage
      n = n + 1
    End If
    For j = 1 To 4
      tb(n, j) = ta(i, j)
    Next j
  Else
    d(x) = i 'mémorisation de la 1ère ligne des doublons
  End If
Next i
'---restitution---
If n Then
  With [L2].Resize(n, ncol)
    .Value = tb
    .Offset(n).Resize(Rows.Count - n - 1).ClearContents
  End With
End If
End Sub

Private Sub CommandButton1_Click() 'bouton Doublons
Dim ta, ncol%, tb(), d As Object, i&, x$, n&, j%
ta = [T] 'matrice, plus rapide
ncol = UBound(ta, 2)
ReDim tb(1 To UBound(ta), 1 To ncol + 1) 'une colonne de plus, pour le tri
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(ta)
  x = ta(i, 6) & " " & ta(i, 7) & " " & ta(i, 8) & " " & ta(i, 9) & " " & ta(i, 10)
  If d.exists(x) Then
    n = n + 1
    If ta(d(x), 1) <> Chr(1) Then
      For j = 1 To ncol
        tb(n, j) = ta(d(x), j)
      Next j
      ta(d(x), 1) = Chr(1) 'repérage
      tb(n, ncol + 1) = d(x) 'pour permettre le tri
      n = n + 1
    End If
    For j = 1 To 4
      tb(n, j) = ta(i, j)
    Next j
    tb(n, ncol + 1) = d(x) 'pour permettre le tri
  Else
    d(x) = i 'mémorisation de la 1ère ligne des doublons
  End If
Next i
'---restitution---
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'à cause de la MFC
If n Then
  With [L2].Resize(n, ncol + 1)
    .Value = tb
    .Sort .Columns(ncol + 1), xlAscending, Header:=xlNo 'tri
    .Columns(ncol + 1).ClearContents
  End With
End If
[L2].Offset(n).Resize(Rows.Count - n - 1, ncol).ClearContents
Application.Calculation = xlCalculationAutomatic
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [Q1:U1]) Is Nothing Then Exit Sub
Dim ncol%, x$, ta, tb(), i&, y$, n&, j%
ncol = 4
If Application.Count([Q1:U1]) < 5 Then GoTo 1
x = [Q1] & " " & [R1] & " " & [S1] & " " & [T1] & " " & [U1]
ta = [T] 'matrice, plus rapide
ReDim tb(1 To UBound(ta), 1 To ncol)
For i = 1 To UBound(ta)
  y = ta(i, 6) & " " & ta(i, 7) & " " & ta(i, 8) & " " & ta(i, 9) & " " & ta(i, 10)
  If x = y Then
    n = n + 1
    For j = 1 To ncol
      tb(n, j) = ta(i, j)
    Next j
  End If
Next i
'---restitution---
If n Then [L2].Resize(n, ncol) = tb
1 [L2].Offset(n).Resize(Rows.Count - n - 1, ncol).ClearContents
End Sub