comment découper une liste dans différents onglets

Sub Extrait()
  Set f = Sheets("BD")
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  Set Rng = f.Range("A2:C" & f.[a65000].End(xlUp).Row)
  Rng.Sort key1:=f.[B2]
  a = Rng
  i = 1: n = 0
  Do While i <= UBound(a)
    code = a(i, 2)
    Do While a(i, 2) = code
      i = i + 1: If i > UBound(a) Then Exit Do
    Loop
    On Error Resume Next: Sheets(code).Delete: On Error GoTo 0
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = code
    f.Cells(2 + n, 1).Resize(i - n - 1, 3).Copy [A2]
    f.[A1:C1].Copy [a1]
    n = i - 1
  Loop
End Sub

Sub Extrait()
  t = Timer()
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  Sheets("Données").Copy Before:=Sheets(1)
  Set f = ActiveSheet
  Set Rng = f.Range("A2:C" & f.Cells(f.Rows.Count, 1).End(xlUp).Row)
  Rng.Sort key1:=f.[B2]
  a = Rng
  i = 1: n = 0
  Do While i <= UBound(a)
    code = a(i, 2)
    Do While a(i, 2) = code
      i = i + 1: If i > UBound(a) Then Exit Do
    Loop
    On Error Resume Next: Sheets(code).Delete: On Error GoTo 0
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = code
    f.Cells(2 + n, 1).Resize(i - n - 1, 3).Copy [A2]
    f.[A1:C1].Copy [a1]
    n = i - 1
  Loop
  Sheets(1).Delete
  MsgBox Timer() - t
End Sub

Sub Extrait()
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  Sheets("BD").Copy Before:=Sheets(1)
  Set f = Sheets(1)
  Ncol = 3                ' Adapter ou Ncol=f.[A1].CurrentRegion.Columns.Count
  colCritère = 2        ' adapter
  Derlig = f.[a65000].End(xlUp).Row
  Set Rng = f.Cells(2, 1).Resize(Derlig, Ncol)
  Rng.Sort key1:=f.Cells(2, colCritère)
  TblCrit = f.Cells(2, colCritère).Resize(Derlig - 1)
  i = 1: Premier = 1
  Do While i <= UBound(TblCrit)
    code = TblCrit(i, 1)
    Do While TblCrit(i, 1) = code
      i = i + 1: If i > UBound(TblCrit) Then Exit Do
    Loop
    On Error Resume Next: Sheets(code).Delete: On Error GoTo 0
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = code
    f.Cells(1 + Premier, 1).Resize(i - Premier, Ncol).Copy [A2]
    f.Cells(1, 1).Resize(, Ncol).Copy [A1]
    Premier = i
  Loop
  Sheets(1).Delete
End Sub

Sub aEssai()
Dim t0!, t1!
  init
  DoEvents
  t0 = Timer
  Essai
  t1 = Timer
  Feuil1.Activate
  MsgBox t1 - t0 - 86400 * (t1 < t0)
End Sub

Sub Essai()
Dim R As Range, Rcode As Range, d As Object, tCode, i&, dk, di, pl&, Dlig&, Plig&
Application.ScreenUpdating = False: Application.DisplayAlerts = False
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Temp"
Sheets("Données").[A1].CurrentRegion.Copy Sheets("temp").[A1]
Set R = Sheets("temp").[A1].CurrentRegion

With Worksheets("Temp").Sort
  .SortFields.Clear
  .SortFields.Add Key:=R.Columns(2) _
  , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
  .SetRange R.Columns(2)
  .Header = xlYes
  .Apply
End With

Sheets("temp").Rows(1).Delete

Set Rcode = R.Columns(2)
tCode = Rcode
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(tCode): d(CStr(tCode(i, 1))) = d(CStr(tCode(i, 1))) + 1: Next
dk = d.Keys: di = d.Items

Plig = 1: Dlig = di(0)

For i = 0 To UBound(dk)
  On Error Resume Next
  Sheets.Add After:=Sheets(Sheets.Count)
  ActiveSheet.Name = dk(i)
   
  With Sheets(dk(i))
    .Cells(1, 1) = "NOM": .Cells(1, 2) = "CODE": .Cells(1, 3) = "ADRESSE"
    Sheets("temp").Range(Sheets("temp").Cells(Plig, 1), Sheets("temp").Cells(Dlig, 3)).Copy Sheets(dk(i)).Cells(2, 1)
  End With
  
  Plig = Dlig + 1: Dlig = Dlig + di(i + 1)
Next i

Sheets("temp").Delete
Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub

  t = Timer()
  i = 1: Premier = 1
  n = UBound(TblCrit)
  Do While i <= n
    code = TblCrit(i, 1)
    Do While TblCrit(i, 1) = code
      i = i + 1: If i > n Then Exit Do
    Loop
    Premier = i
  Loop
  MsgBox Timer() - t