Option Explicit
Sub test()
Dim a, b(), w(), e, i As Long, n As Long
With Sheets("feuil1").Range("a2").CurrentRegion
a = .Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 2)) Then
ReDim w(1 To 2)
w(1) = 0
Set w(2) = CreateObject("Scripting.Dictionary")
'w(2).CompareMode = 1
Else
w = .Item(a(i, 2))
End If
If Not w(2).exists(a(i, 1)) Then
w(2)(a(i, 1)) = Empty
w(1) = w(1) + 1
End If
.Item(a(i, 2)) = w
Next
ReDim b(1 To .Count + 1, 1 To 2)
n = 1
b(n, 1) = "Technicien"
b(n, 2) = "N° de série"
For Each e In .keys
n = n + 1
b(n, 1) = e
b(n, 2) = .Item(e)(1)
Next
End With
End With
'Restitution
Application.ScreenUpdating = False
With Sheets("Feuil2").Range("a1")
.CurrentRegion.Cells.Clear
With .Resize(UBound(b, 1), UBound(b, 2))
.Value = b
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
With .Rows(1)
.Font.Size = 11
.Interior.ColorIndex = 44
.BorderAround Weight:=xlThin
.HorizontalAlignment = xlCenter
End With
.Columns(1).HorizontalAlignment = xlCenter
End With
.Parent.Activate
End With
Application.ScreenUpdating = True
End Sub