Private Sub REPORTER_Click()
Dim ncol%, source As Range, deb As Range, rest(), d As Object, i&, n&, j%, t, titre
ncol = 6 'nombre de colonnes
Set source = [K7].CurrentRegion.Resize(, ncol - 1) 'plage à adapter
Set deb = [C7] '1ère cellule des titres, à adapter
Application.ScreenUpdating = False
deb(2).Resize(Rows.Count - deb.Row, ncol).Delete xlUp 'RAZ
If source.Rows.Count = 1 Then Exit Sub
t = source 'matrice, plus rapide
ReDim rest(1 To UBound(t), 1 To ncol)
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
'--tableau sans doublon et comptage---
For i = 2 To UBound(t)
If Not d.exists(t(i, 3)) Then
n = n + 1
d(t(i, 3)) = n 'repérage de la ligne
For j = 1 To ncol - 1
rest(n, j) = t(i, j)
Next j
End If
rest(d(t(i, 3)), ncol) = rest(d(t(i, 3)), ncol) + 1 'comptage Nombre
Next i
With deb(2).Resize(n, ncol)
.Value = rest 'restitution
.Sort .Columns(1), xlAscending, .Columns(3), , xlAscending, Header:=xlNo 'tri
t = .Value
End With
'---insertion de lignes et titres---
titre = deb.Resize(, ncol)
ReDim rest(1 To 3 * n, 1 To ncol)
For j = 1 To ncol: rest(1, j) = t(1, j): Next '1ère ligne
n = 1
For i = 2 To UBound(t)
If LCase(t(i, 1)) > LCase(t(i - 1, 1)) Then
n = n + 2
For j = 1 To ncol
rest(n, j) = titre(1, j)
Next j
End If
n = n + 1
For j = 1 To ncol
rest(n, j) = t(i, j)
Next j
Next i
'---tableau final avec bordures---
With deb(2).Resize(n, ncol)
.Value = rest 'restitution
Intersect(.Cells, .Columns(1).SpecialCells(xlCellTypeConstants).EntireRow) _
.Borders.Weight = xlThin
.Columns(3).Borders(xlEdgeRight).LineStyle = xlNone
End With
'Nota : la couleur des lignes des titres est appliquée par MFC
With Me.UsedRange: End With 'actualise si nécessaire la barre de défilement verticale
End Sub