XL 2016 Macro insérer/supprimer des lignes dans plusieurs feuilles

Private Sub CommandButton1_Click() 'bouton Mise à jour des feuilles
Dim d As Object, i&, a, w As Worksheet, col As Variant, b() As Variant, j%
'---liste des noms-prénoms (sans doublon)---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
With ListObjects(1).DataBodyRange
    .Sort .Columns(2), xlAscending, Header:=xlYes 'tri sur les noms-prénoms
    For i = 1 To .Rows.Count
        If .Cells(i, 2) <> "" Then d(.Cells(i, 2).Value) = d.Count 'numérotation (commence à 0)
    Next i
End With
If d.Count Then a = d.keys
'---traitement des feuilles---
For Each w In Worksheets
    If w.Name <> Me.Name Then
        If w.ListObjects.Count Then
            With w.ListObjects(1).DataBodyRange
                col = Application.Match("*Nom*Prénom*", .Rows(-1), 0)
                If IsNumeric(col) Then
                    '---repérage des noms-prénoms listés et suppression des autres---
                    If d.Count Then ReDim b(d.Count - 1) 'tableau base 0 vide
                    For i = .Rows.Count To 1 Step -1
                        If d.exists(.Cells(i, col).Value) Then
                            b(d(.Cells(i, col).Value)) = 1
                        Else
                            If i > 1 Then
                                .Rows(i).Delete xlUp
                            Else 'traitement particulier de la 1ère ligne
                                For j = 1 To .Columns.Count
                                    If Not .Cells(1, j).HasFormula Then .Cells(1, j) = "" 'efface les constantes
                                Next j
                            End If
                        End If
                    Next i
                    '---ajout des noms-prénoms manquants dans les cellules vides---
                    If d.Count Then
                        For i = 0 To UBound(a)
                            If IsEmpty(b(i)) Then .Columns(col).EntireColumn.Find("", .Cells(0, col), xlValues) = a(i)
                        Next i
                    End If
                    '---tri sur les noms-prénoms---
                    .Sort .Columns(col), xlAscending, Header:=xlYes
                End If
            End With
        End If
    End If
Next w
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object) 'se lance quand on active une feuille quelconque
Dim F As Worksheet, d As Object, i&, a, w As Worksheet, col As Variant, b() As Variant, j%
Set F = Feuil1 'CodeName de la feuille "Classe", adapter si nécessaire
Application.ScreenUpdating = False
'---liste des noms-prénoms (sans doublon)---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
With F.ListObjects(1).DataBodyRange
    .Sort .Columns(2), xlAscending, Header:=xlYes 'tri sur les noms-prénoms
    For i = 1 To .Rows.Count
        If .Cells(i, 2) <> "" Then d(.Cells(i, 2).Value) = d.Count 'numérotation (commence à 0)
    Next i
End With
If d.Count Then a = d.keys
'---traitement des feuilles---
For Each w In Worksheets
    If w.Name <> F.Name Then
        If w.ListObjects.Count Then
            With w.ListObjects(1).DataBodyRange
                col = Application.Match("*Nom*Prénom*", .Rows(-1), 0)
                If IsNumeric(col) Then
                    '---repérage des noms-prénoms listés et suppression des autres---
                    If d.Count Then ReDim b(d.Count - 1) 'tableau base 0 vide
                    For i = .Rows.Count To 1 Step -1
                        If d.exists(.Cells(i, col).Value) Then
                            b(d(.Cells(i, col).Value)) = 1
                        Else
                            If i > 1 Then
                                .Rows(i).Delete xlUp
                            Else 'traitement particulier de la 1ère ligne
                                For j = 1 To .Columns.Count
                                    If Not .Cells(1, j).HasFormula Then .Cells(1, j) = "" 'efface les constantes
                                Next j
                            End If
                        End If
                    Next i
                    '---ajout des noms-prénoms manquants dans les cellules vides---
                    If d.Count Then
                        For i = 0 To UBound(a)
                            If IsEmpty(b(i)) Then .Columns(col).EntireColumn.Find("", .Cells(0, col), xlValues) = a(i)
                        Next i
                    End If
                    '---tri sur les noms-prénoms---
                    .Sort .Columns(col), xlAscending, Header:=xlYes
                End If
            End With
        End If
    End If
Next w
End Sub

With F.ListObjects(1).DataBodyRange
    .Sort .Columns(2), xlAscending, Header:=xlYes 'tri sur les noms-prénoms
    For i = .Rows.Count To 2 Step -1
        If .Cells(i, 2) = "" Then .Rows(i).Delete xlUp Else Exit For 'supprime les cellules vides
    Next i
    For i = i To 1 Step -1
        If d.exists(CStr(.Cells(i, 2))) Then
            .Rows(i).Delete xlUp 'supprime les doublons
        Else
            d(CStr(.Cells(i, 2))) = d.Count 'numérotation (commence à 0)
        End If
    Next i
End With

Private Sub Workbook_SheetActivate(ByVal Sh As Object): End