Microsoft 365 Rechercher des blocs de valeurs dans multiples feuilles du même classeur et les empiler

Sub Worksheet_Activate()
    Dim LigneRefC%, LigneRefD%, DL%, i%, j%, Nmax%
    Nmax = 100  ' Nombre max de lignes et colonnes à analyser pour trouver la dernière
    LigneRefC = 2: LigneRefD = 2
    [A2:B1000].ClearContents: [A1:B1000].Borders.LineStyle = xlNone
    For Each F In Worksheets
        If F.Name <> "Synthèse" Then
            For L = 1 To Nmax    ' Dernière ligne
                DL = Application.Max(DL, Sheets(F.Name).Cells(65000, L).End(xlUp).Row)
            Next L
            For C = 1 To Nmax    ' Dernière colonne
                DC = Application.Max(DC, Sheets(F.Name).Cells(C, Columns.Count).End(xlToLeft).Column)
            Next C
            With Sheets(F.Name)
                T = .Range(.Cells(1, 1), .Cells(DL, DC))
            End With
            For i = 1 To UBound(T)
                For j = 1 To UBound(T, 2)
                    If T(i, j) = "REF C" Then
                        Cells(LigneRefC, "A") = T(i, j + 2)
                        LigneRefC = LigneRefC + 1
                    End If
                    If T(i, j) = "REF D" Then
                        Cells(LigneRefD, "B") = T(i, j + 2)
                        LigneRefD = LigneRefD + 1
                    End If
                Next j
            Next i
        End If
    Next F
    DL = Application.Max(Cells(65000, "A").End(xlUp).Row, Cells(65000, "B").End(xlUp).Row)
    Range("A1:B" & DL).Borders.Weight = xlThin
End Sub

Sub GenererTab()
Dim c As Range
Dim firstAddress As String

Numtab = 1
For Each ws In ActiveWorkbook.Sheets
With ws
    
    With .Cells
        Set c = .Find("REF A", LookIn:=xlValues)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                Set NewTab = c.CurrentRegion
    
                ActiveWorkbook.Names.Add Name:="Tab_" & Numtab, RefersTo:=NewTab
                Numtab = Numtab + 1
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
    End With
End With
Next ws

For i = 1 To Numtab - 1
    Application.Goto Reference:="Tab_" & i
    Set NewTab = Range("Tab_" & i)
    ActiveSheet.ListObjects.Add(xlSrcRange, NewTab, , xlNo).Name = "Tab_" & i
    ActiveSheet.ListObjects("Tab_" & i).TableStyle = "TableStyleMedium2"
    ActiveSheet.ListObjects("Tab_" & i).ShowHeaders = False
Next i
End Sub