Sub Consolider()
Dim tablo, resu(), d As Object, i&, x$, n&, j%, nn&, v
'---2ème tableau---
Application.ScreenUpdating = False
If IsArray([Tbl_2]) Then
With [Tbl_2].ListObject.Range: .AutoFilter: .AutoFilter: End With 'si le tableau est filtré
[Tbl_2].EntireColumn.Delete 'RAZ
End If
With [Tbl_1].ListObject.Range 'tableau structuré
.AutoFilter: .AutoFilter 'si le tableau est filtré
.EntireColumn.Copy .Columns(7).EntireColumn 'copier-coller
.Cells(2, 7).ListObject.Name = "Tbl_2" 'renomme le tablea
tablo = .Value 'matrice, plus rapide
End With
'---tableau des résultats---
ReDim resu(1 To UBound(tablo), 1 To 5)
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(tablo)
x = tablo(i, 2) & Chr(1) & tablo(i, 3) 'concatène les 2ème et 3ème colonnes
If x <> Chr(1) And tablo(i, 4) > 5 Then
If Not d.exists(x) Then
n = n + 1
d(x) = n 'mémorise la ligne
For j = 1 To 4: resu(n, j) = tablo(i, j): Next j
End If
nn = d(x) 'récupère la ligne
v = tablo(i, 5)
If IsNumeric(CStr(v)) Then resu(nn, 5) = resu(nn, 5) + CDbl(v)
End If
Next i
'---tableau consolidé et 6ème colonne---
With [Tbl_2].ListObject.Range 'tableau structuré
If n Then .Rows(2).Resize(n, 5) = resu 'restitution
If .Rows.Count = 2 And n = 0 Then
.Rows(2) = "" 'si le tableau est vide
Else
If .Rows.Count > n + 1 Then .Rows(n + 2).Resize(.Rows.Count - n - 1).Delete xlUp 'RAZ en dessous
.Columns(2).Insert xlToRight 'insère une colonne auxiliaire
.Cells(2, 2) = "=N(R[-1]C)+1" 'numérotation
.Columns(2) = .Columns(2).Value 'supprime les formules
.Sort .Columns(4), xlAscending, .Columns(6), , xlDescending, Header:=xlYes 'tri sur 2 colonnes
tablo = .Columns(4) 'matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To 1)
For i = 2 To UBound(tablo)
If tablo(i - 1, 1) <> tablo(i, 1) Then n = 1 Else n = n + 1
If n < 3 Then resu(i, 1) = "Oui"
Next i
.Columns(7) = resu 'restitution
.Sort .Columns(2), xlAscending, Header:=xlYes 'tri dans l'ordre initial
.Columns(2).Delete xlToLeft 'supprime la colonne auxiliaire
End If
.Cells(1, 6) = "Client à considérer"
.Cells(1, 6).Columns.AutoFit 'ajustement largeur
.ListObject.TableStyle = "TableStyleMedium6" 'bleu
End With
End Sub
)
