Éclater un tableau de données en plusieurs pavés pour dissocie les doublons/triplons/

Private Sub Worksheet_Activate()
Dim saut As Byte, t, ncol%, d As Object, i&, x$, ntab&, rest(), n&, j%
'---préparation et numérotation des lignes---
saut = 1 'nombre de lignes à sauter, à adapter
With Sheets("Base").[A3].CurrentRegion
  t = .Resize(, .Columns.Count + 1) '1 colonne de plus
End With
ncol = UBound(t, 2)
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(t)
  x = CStr(t(i, 2)) 'matricule
  d(x) = d(x) + 1 'rang des doublons
  t(i, ncol) = d(x) 'numérotation en dernière colonne
Next i
If d.Count = 0 Then GoTo 1 'si le tableau est vide
ntab = Application.Max(d.items) 'nombre de tableaux à créer
ReDim rest(1 To UBound(t) + saut * ntab, 1 To ncol - 1)
'---création des tableaux---
For ntab = 1 To ntab
  For i = 2 To UBound(t)
    If t(i, ncol) = ntab Then
      n = n + 1
      For j = 1 To ncol - 1
        rest(n, j) = t(i, j)
      Next j
    End If
  Next i
  n = n + saut 'sauts de lignes
Next ntab
'---restitution---
[A4].Resize(n, ncol - 1) = rest
1 Rows(n + 4 & ":" & Rows.Count).Delete
End Sub

Private Sub Worksheet_Activate()
Dim saut As Byte, t, ncol%, d As Object, i&, x$, ntab&, rest(), n&, j%, a As Range
'---préparation et numérotation des lignes---
saut = 1 'nombre de lignes à sauter, à adapter
With Sheets("Base").[A3].CurrentRegion
  t = .Resize(, .Columns.Count + 1) '1 colonne de plus
End With
ncol = UBound(t, 2)
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(t)
  x = CStr(t(i, 2)) 'matricule
  If x <> "" Then
    If IsNumeric(x) Then t(i, 2) = CDbl(x) 'conversion
    d(x) = d(x) + 1 'rang des doublons
    t(i, ncol) = d(x) 'numérotation en dernière colonne
  End If
Next i
If d.Count = 0 Then GoTo 1 'si le tableau est vide
ntab = Application.Max(d.items) 'nombre de tableaux à créer
ReDim rest(1 To UBound(t) + saut * ntab, 1 To ncol - 1)
'---création des tableaux---
For ntab = 1 To ntab
  For i = 2 To UBound(t)
    If t(i, ncol) = ntab Then
      n = n + 1
      For j = 1 To ncol - 1
        rest(n, j) = t(i, j)
      Next j
    End If
  Next i
  n = n + saut 'sauts de lignes
Next ntab
'---restitution et tri---
Application.ScreenUpdating = False
With [A4].Resize(n, ncol - 1)
  .Value = rest
  Set a = .Columns(2).SpecialCells(xlCellTypeConstants)
  For Each a In a.Areas
    a.EntireRow.Sort a, xlAscending, Header:=xlNo 'tri
  Next
End With
1 Rows(n + 4 & ":" & Rows.Count).Delete
End Sub

 Application.Max(d.items)

Sub Doublons()
  a = Range("A2:H" & [A65000].End(xlUp).Row).Value
  Set d = CreateObject("scripting.dictionary")
  For i = LBound(a) To UBound(a)
    d(CStr(a(i, 2))) = d(CStr(a(i, 2))) + 1
    a(i, UBound(a, 2)) = d(CStr(a(i, 2)))
  Next i
  Set f = Sheets("result")
  f.Cells.Clear:  [A1:H1].Copy f.[A1]
  f.[a2].Resize(UBound(a), UBound(a, 2)) = a
  f.[a2].Sort key1:=f.[h2], key2:=f.[b2], Header:=yes
  For i = f.[A65000].End(xlUp).Row To 3 Step -1
    If f.Cells(i, 8) <> f.Cells(i - 1, 8) Then f.Rows(i).Insert
  Next i
End Sub