XL 2016 copie de tableaux les uns sous les autres

Public DL%
Sub Worksheet_Activate()
    Dim F, NomTablo, Tablo, Taille
    Application.ScreenUpdating = False
    For Each F In Worksheets
        If F.Name = "LIST PERS" Then        ' Si List Pers on supprime tableau
            NomTablo = Sheets(F.Name).ListObjects(1)
            Tablo = Sheets(F.Name).ListObjects(NomTablo).DataBodyRange
            Taille = UBound(Tablo)
            Range("A" & Taille + 6) = "x"   ' On prépare la dernière ligne pour le tableau suivant
            Rows("7:" & Taille + 5).Delete Shift:=xlUp
            DL = 7
        Else                                ' Sinon on transfère le tableau de la page considérée
            NomTablo = Sheets(F.Name).ListObjects(1)
            Sheets(F.Name).Range(NomTablo).Copy
            Range("A" & DL).Select
            ActiveSheet.Paste
            Tablo = Sheets("LIST PERS").ListObjects(1).DataBodyRange
            Taille = UBound(Tablo)
            DL = 6 + Taille
            Range("A" & DL) = "x"
        End If
    Next F
    DerLig = 5 + Sheets("LIST PERS").[PERS].Rows.Count
    Rows(DerLig).Delete Shift:=xlUp         ' On supprime la dernière ligne
    [A1].Select
    Application.ScreenUpdating = True
End Sub

For Each F In Worksheets        ' On parcourt toutes les feuilles'
  If F.Name = "LIST PERS" Then  ' Si la feuille s'appelle LIST PERS
                                ' On supprime le tableau
  Else                          ' Sinon'
                                ' On importe le tableau
  EndIf
Next F

Private Sub Worksheet_Activate()
Dim lig&, col%, ncol%, h&, w As Worksheet, P As Range, rc&
Application.ScreenUpdating = False
With ListObjects(1).Range
    If .Rows.Count > 2 Then .Rows(3).Resize(.Rows.Count - 2).Delete xlUp 'RAZ
    .Rows(2).Clear 'RAZ
    lig = .Row
    col = .Column
    ncol = .Columns.Count
End With
h = 1
For Each w In Worksheets
    If w.Name <> Me.Name And w.ListObjects.Count Then
        Set P = Evaluate(w.ListObjects(1).Name) 'tableau sans les en-têtes
        If Application.CountA(P) Then 'si le tableau n'est pas vide
            rc = P.Rows.Count
            ListObjects(1).Resize Cells(lig, col).Resize(h + rc, ncol) 'redimensionne le tableau
            P.Copy Cells(lig + h, col) 'copier-coller
            h = h + rc
        End If
    End If
Next
End Sub

Private Sub Worksheet_Activate()
Dim deb As Range, ncol%, h&, w As Worksheet, P As Range, rc&
Application.ScreenUpdating = False
With ListObjects(1).Range
    If .Rows.Count > 2 Then .Rows(3).Resize(.Rows.Count - 2).Delete xlUp 'RAZ
    .Rows(2).Clear 'RAZ
    Set deb = .Cells(1) '1ère cellule
    ncol = .Columns.Count
End With
h = 1
For Each w In Worksheets
    If w.Name <> Me.Name And w.ListObjects.Count Then
        Set P = Evaluate(w.ListObjects(1).Name) 'tableau sans les en-têtes
        If Application.CountA(P) Then 'si le tableau n'est pas vide
            rc = P.Rows.Count
            ListObjects(1).Resize deb.Resize(h + rc, ncol) 'redimensionne le tableau
            P.Copy deb(h + 1) 'copier-coller
            h = h + rc
        End If
    End If
Next
End Sub