XL 2016 Incrémentation de 2 tableaux automatique à partir d'un seul

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim P As Range, Q As Range, R As Range
Application.ScreenUpdating = False
With Sheets("BASE").[A1].CurrentRegion
    Set P = .Columns(1).Resize(, 3) '3 premières colonnes
    Set Q = .Rows(1).Find(Sh.Name, , xlValues, xlWhole) 'recherche de X ou Y
    If Q Is Nothing Then Exit Sub
    Set Q = Intersect(.Cells, Q.MergeArea.EntireColumn) 'colonnes X ou Y
    Set R = Q.Columns(1).SpecialCells(xlCellTypeConstants).EntireRow 'filtrage
    Sh.Cells.Delete 'EAZ
    Intersect(Union(P, Q), R).Copy Sh.[A1] 'copier-coller
    '---mises en forme---
    With Sh.UsedRange
        Set P =...