XL 2016 ventiler les informations dans les bonnes feuilles du classeur

Option Explicit

Dim ws As Worksheet, dlg&

Private Sub Job(i As Byte)
  Dim An%, lg1&, lg2&, col%
  Worksheets(i).Select
  Rows("9:" & Rows.Count).Delete 'supprime toutes les lignes sous la ligne 8
  Rows(8).ClearContents 'efface toutes les cellules de la ligne 8
  An = Val(ActiveSheet.Name): lg2 = 8
  For lg1 = 8 To dlg + 7
    If ws.Cells(lg1, 20) = An Then
      Rows(lg2).RowHeight = ws.Rows(lg1).RowHeight
      ws.Cells(lg1, 5).Resize(, 16).Copy
      Cells(lg2, 5).PasteSpecial -4163
      lg2 = lg2 + 1
    End If
  Next lg1
  [F8].Select
End Sub

Sub ventilation()
  Dim i As Byte
  Application.ScreenUpdating = 0: Set ws = Worksheets("Source")
  dlg = ws.ListObjects("suividestextes3456").ListRows.Count
  For i = 1 To 6: Job i: Next i: Application.CutCopyMode = 0
  ws.Select: MsgBox "Ventilation effectuée."
End Sub

Sub Ventilation()
Dim d As Object, w As Worksheet, P As Range, i&, x$, Q As Range
Application.ScreenUpdating = False
With Sheets("Source")
    Set d = CreateObject("Scripting.Dictionary")
    d.CompareMode = vbTextCompare 'la casse est ignorée
    For Each w In Worksheets
        If w.Name <> .Name Then d(w.Name) = "" 'liste des feuilles
    Next w
    Set P = .ListObjects(1).Range 'tableau structuré
End With
For i = 2 To P.Rows.Count
    x = CStr(P(i, 16))
    If d.exists(x) Then
        With Sheets(x)
            Set Q = .ListObjects(1).Range 'tableau structuré
            If Q.Rows.Count > 2 Then Q.Rows(3).Resize(Q.Rows.Count - 2).Delete xlUp
            P.AutoFilter 16, x 'filtre automatique
            P.Rows(2).Resize(P.Rows.Count - 1).Copy Q(2, 1)
            P.AutoFilter
            .Rows.AutoFit 'ajustement hauteur
        End With
        d.Remove x 'on retire l'item puisqu'il a été traité
    End If
Next i
End Sub

Option Explicit

Dim ws As Worksheet, dlg&

Private Sub Job(i As Byte)
  Dim An%, lg1&, lg2&, col%
  Worksheets(i).Select
  Rows("9:" & Rows.Count).Delete 'supprime toutes les lignes sous la ligne 8
  Rows(8).ClearContents 'efface toutes les cellules de la ligne 8
  An = Val(ActiveSheet.Name): lg2 = 8
  For lg1 = dlg + 7 To 8 Step -1
    If ws.Cells(lg1, 20) = An Then
      Rows(lg2).RowHeight = ws.Rows(lg1).RowHeight
      ws.Cells(lg1, 5).Resize(, 16).Copy
      Cells(lg2, 5).PasteSpecial -4163
      lg2 = lg2 + 1
      ws.ListObjects("suividestextes3456").ListRows(lg1 - 7).Delete
    End If
  Next lg1
  [F8].Select
End Sub

Sub ventilation()
  Dim i As Byte
  Application.ScreenUpdating = 0: Set ws = Worksheets("Source")
  dlg = ws.ListObjects("suividestextes3456").ListRows.Count
  For i = 1 To 6: Job i: Next i: Application.CutCopyMode = 0
  ws.Select: Application.ScreenUpdating = -1
  MsgBox "Ventilation effectuée."
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Not Sh.Name Like "####" Then Exit Sub
Dim P As Range, Q As Range
Set P = Sheets("Source").ListObjects(1).Range 'tableau structuré
Set Q = Sh.ListObjects(1).Range 'tableau structuré
Application.ScreenUpdating = False
If Q.Rows.Count > 2 Then Q.Rows(3).Resize(Q.Rows.Count - 2).Delete xlUp
Q.Rows(2) = ""
If Application.CountIf(P.Columns(16), Sh.Name) = 0 Then Exit Sub
P.AutoFilter 16, Sh.Name 'filtre automatique
P.Rows(2).Resize(P.Rows.Count - 1).Copy Q(2, 1)
P.AutoFilter
Sh.Rows.AutoFit 'ajustement hauteur
End Sub

Private Sub Job(i As Byte)
  Dim An%, lg1&, lg2&, col%
  Application.EnableEvents = 0
  Worksheets(i).Select
  Application.EnableEvents = -1

Private Sub Worksheet_Change(ByVal Target As Range)
With ListObjects(1).Range.Columns(1)
    Application.EnableEvents = False
    If Not Intersect(Target, .Cells) Is Nothing Then Application.Undo 'annule les modifications manuelles en 1ère colonne
    If Application.CountBlank(.Cells) Then
        For Each Target In .Cells.SpecialCells(xlCellTypeBlanks)
            Target = Application.Max(.Cells) + 1
        Next
    End If
    Application.EnableEvents = True
End With
End Sub