VBA Copie données relative au sous.totaux

Sub SousTotaux()
Dim P As Range, dest As Range, col%, lig&, d As Object
Dim i&, filtre As Range, h&, c As Range, adr$, j&
Set P = Sheets("BDD").[B1].CurrentRegion 'à adapter
Set dest = Sheets("Sous-totaux").[B2] 'à adapter
Application.ScreenUpdating = False
dest(2).Resize(Rows.Count - dest.Row).EntireRow.Delete 'RAZ
col = P.Columns.Count
lig = 2
Set d = CreateObject("Scripting.Dictionary")
P.AutoFilter 'met en place ou retire le filtre automatique
For i = 2 To P.Rows.Count
  If Not d.Exists(P(i, 1).Value) Then 'élimine les doublons
    d(P(i, 1).Value) = ""
    P.AutoFilter 1, P(i, 1) 'filtrage 1ère colonne
    Set filtre = P.Offset(1).SpecialCells(xlCellTypeVisible)
    h = filtre.Count / col
    Set c = dest(lig)
    filtre.Copy c 'copie la plage filtrée
    adr = c(1, col - 1).Resize(h - 1).Address(0, 0)
    c(h, col - 1) = "=SUBTOTAL(9," & adr & ")"
    If c(h, col - 1) > 500 Then 'critère adaptable
      c(h) = c
      c(h, 2) = c(h - 1, 2) 'le dernier nom
      For j = 1 To h - 1
        c(j, col) = IIf(c(j, 4) = "5I", Right(c(j, col), 8), "")
      Next
      c(h, 2).Font.Bold = True 'gras
      c(h, col - 1).Interior.ColorIndex = 6 'jaune
      lig = lig + h
    Else
      c.Resize(h).EntireRow.Delete 'plage supprimée
    End If
  End If
Next
P.AutoFilter 'retire le filtre
dest(lig, 2) = "général"
dest(lig, 2).Font.Bold = True 'gras
adr = dest(1, col - 1).Resize(lig - 1).Address(0, 0)
dest(lig, col - 1) = "=SUBTOTAL(9," & adr & ")"
dest(lig, col - 1).NumberFormat = dest(lig - 1, col - 1).NumberFormat
dest.Resize(, col).EntireColumn.AutoFit 'ajustement largeur
dest.Resize(lig - 1, col).Sort dest, Header:=xlYes 'tri 1ère colonne
dest.Parent.Activate
End Sub

Sub SousTotaux()
Dim choix As Boolean, P As Range, dest As Range, col%, lig&
Dim d As Object, i&, filtre As Range, h&, c As Range, adr$, j&
Set P = Sheets("BDD").[B1].CurrentRegion 'à adapter
Set dest = Sheets("Sous-totaux").[B2] 'à adapter
choix = MsgBox("Voulez-vous trier par sous-total ?", 36, "Tri") = 6
Application.ScreenUpdating = False
dest(2).Resize(Rows.Count - dest.Row).EntireRow.Delete 'RAZ
col = P.Columns.Count
lig = 2
Set d = CreateObject("Scripting.Dictionary")
P.AutoFilter 'met en place ou retire le filtre automatique
For i = 2 To P.Rows.Count
  If Not d.Exists(P(i, 1).Value) Then 'élimine les doublons
    d(P(i, 1).Value) = ""
    P.AutoFilter 1, P(i, 1) 'filtrage 1ère colonne
    Set filtre = P.Offset(1).SpecialCells(xlCellTypeVisible)
    h = filtre.Count / col
    Set c = dest(lig)
    filtre.Copy c 'copie la plage filtrée
    adr = c(1, col - 1).Resize(h - 1).Address(0, 0)
    c(h, col - 1) = "=SUBTOTAL(9," & adr & ")"
    If c(h, col - 1) > 500 Then 'critère adaptable
      c(h) = c
      c(h, 2) = c(h - 1, 2) 'le dernier nom
      For j = 1 To h - 1
        c(j, col) = IIf(c(j, 4) = "5I", Right(c(j, col), 8), "")
      Next
      If choix Then c(1, col + 1).Resize(h) = c(h, col - 1)
      c(h, 2).Font.Bold = True 'gras
      c(h, col - 1).Interior.ColorIndex = 6 'jaune
      lig = lig + h
    Else
      c.Resize(h).EntireRow.Delete 'plage supprimée
    End If
  End If
Next
P.AutoFilter 'retire le filtre
dest(lig, 2) = "général"
dest(lig, 2).Font.Bold = True 'gras
adr = dest(1, col - 1).Resize(lig - 1).Address(0, 0)
dest(lig, col - 1) = "=SUBTOTAL(9," & adr & ")"
dest(lig, col - 1).NumberFormat = dest(lig - 1, col - 1).NumberFormat
dest.Resize(, col).EntireColumn.AutoFit 'ajustement largeur
dest.Resize(lig - 1, col + 1) _
  .Sort dest(1, 1 - col * choix), 1 - choix, Header:=xlYes 'tri selon choix
If choix Then dest(1, col + 1).EntireColumn.Delete
dest.Parent.Activate
End Sub