Recherche sur plusieurs onglets et récap dynamique

SELECT *, '20.10'
FROM `T:\TEMP\EssaiOnglets.xlsx`.`'20#10$'` `'20#10$'`
where Dénomination  <>null
union all SELECT *, '21.10'
FROM `T:\TEMP\EssaiOnglets.xlsx`.`'21#10$'` `'21#10$'`
where Dénomination  <>null
union all 
SELECT *, '23.10'
FROM `T:\TEMP\EssaiOnglets.xlsx`.`'23#10$'` `'23#10$'`
where Dénomination  <>null

Private Sub Worksheet_Activate()
Dim ncol%, colref%, x$, w As Worksheet, t, i&, n&, rest(), j%
ncol = 10 'nombre de colonnes des tableaux source
colref = IIf([B1] = "Cuve", 1, 7)
x = IIf([B1] = "", "", IIf([B1] = "Cuve", "C" & [B2], "*" & [B3] & "*"))
Application.ScreenUpdating = False
Rows("2:3").Hidden = False
If [B1] = "Cuve" Then Rows(3).Hidden = True _
  Else: If [B1] = "Code" Then Rows(2).Hidden = True
Rows("6:" & Rows.Count).Delete 'RAZ
For Each w In Worksheets
  If w.Name <> Me.Name Then
    t = w.[A1].CurrentRegion.Resize(, ncol).Value2
    For i = 2 To UBound(t)
      If x = "" Or t(i, colref) Like x Then
        n = n + 1
        ReDim Preserve rest(1 To ncol + 1, 1 To n)
        rest(1, n) = w.Name
        For j = 1 To ncol
          rest(j + 1, n) = t(i, j)
        Next j
      End If
    Next i
  End If
Next
'---restitution, tri et bordures---
If n = 0 Then Exit Sub
With [A6].Resize(n, ncol + 1)
  .Value = Application.Transpose(rest)
  .Sort .Columns(1), xlAscending, Header:=xlNo
  For j = 7 To 10
    .Borders(j).Weight = xlMedium 'contour
  Next j
  .Borders(xlInsideVertical).Weight = xlThin
  .Borders(xlInsideHorizontal).Weight = xlHairline
End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [B1:B3]) Is Nothing Then Worksheet_Activate
End Sub

Private Sub Worksheet_Activate()
Dim P As Range, lig&, w As Worksheet, h&, col%, critere$
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set P = ListObjects(1).Range
P.AutoFilter
P.Offset(1).ClearContents 'RAZ
lig = 2
'---transfert des valeurs des feuilles---
For Each w In Worksheets
  If w.Name <> Me.Name Then
    With w.ListObjects(1).DataBodyRange
      h = .Rows.Count
      P(lig, 1).Resize(h) = w.Name
      P(lig, 2).Resize(h, .Columns.Count) = .Value
      lig = lig + h
    End With
  End If
Next
'---cellules B1 B2 B3---
Rows("2:3").Hidden = False
If [B1] = "Cuve" Then Rows(3).Hidden = True _
  Else If [B1] = "Code" Then Rows(2).Hidden = True
col = IIf([B1] = "Cuve", 2, 8)
critere = IIf([B1] = "Cuve", "C" & [B2], "*" & [B3] & "*")
'---mise en forme du tableau et filtrage---
ListObjects(1).Resize P.Resize(lig - 1) 'redimensionnement
With ListObjects(1).Range
  .Sort .Columns(1), xlAscending, Header:=xlYes 'tri
  .AutoFilter 1
  If [B1] <> "" And (col = 2 And [B2] <> "" Or col = 8 And [B3] <> "") _
    Then .AutoFilter col, critere
End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [B1:B3]) Is Nothing Then Worksheet_Activate
End Sub

Private Sub Worksheet_Change(ByVal R As Range)
  If R = "" Then [T].AutoFilter: Exit Sub
  If R.Address = "$B$1" Then [B2] = "": [T].AutoFilter 2, "C" & R
  If R.Address = "$B$2" Then [B1] = "": [T].AutoFilter 8, R & "*"
End Sub

Private Sub Worksheet_Activate()
Dim P As Range, ncol%, w As Worksheet, t, i&, n&, rest(), j%, col%, critere$
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set P = ListObjects(1).Range
ncol = P.Columns.Count
P.AutoFilter 'RAZ
P.Offset(1).ClearContents 'RAZ
'---transfert des valeurs des feuilles---
For Each w In Worksheets
  If w.Name <> Me.Name Then
    t = w.ListObjects(1).Range.Resize(, ncol - 1).Value2
    For i = 2 To UBound(t)
      n = n + 1
      ReDim Preserve rest(1 To ncol, 1 To n)
      rest(1, n) = w.Name
      For j = 2 To ncol
        rest(j, n) = t(i, j - 1)
    Next j, i
  End If
Next w
'---cellules B1 B2 B3---
Rows("2:3").Hidden = False
If [B1] = "Cuve" Then Rows(3).Hidden = True _
  Else If [B1] = "Code" Then Rows(2).Hidden = True
col = IIf([B1] = "Cuve", 2, 8)
critere = IIf([B1] = "Cuve", "C" & [B2], "*" & [B3] & "*")
'---mise en forme du tableau et filtrage---
P.Offset(1).Resize(n) = Application.Transpose(rest) 'restitution
ListObjects(1).Resize P.Resize(n + 1) 'redimensionnement
With ListObjects(1).Range
  .Sort .Columns(1), xlAscending, Header:=xlYes 'tri
  .AutoFilter 1
  If [B1] <> "" And (col = 2 And [B2] <> "" Or col = 8 And [B3] <> "") _
    Then .AutoFilter col, critere
End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [B1:B3]) Is Nothing Then Worksheet_Activate
End Sub

Private Sub Worksheet_Activate()
Dim P As Range, ncol%, rest(), w As Worksheet, t, i&, n&, j%, col%, critere$
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set P = ListObjects(1).Range
ncol = P.Columns.Count
ReDim rest(1 To Rows.Count, 1 To ncol)
P.AutoFilter 'RAZ
P.Offset(1).ClearContents 'RAZ
'---transfert des valeurs des feuilles---
For Each w In Worksheets
  If w.Name <> Me.Name Then
    t = w.ListObjects(1).Range.Resize(, ncol - 1).Value2
    For i = 2 To UBound(t)
      n = n + 1
      rest(n, 1) = w.Name
      For j = 2 To ncol
        rest(n, j) = t(i, j - 1)
    Next j, i
  End If
Next w
'---cellules B1 B2 B3---
Rows("2:3").Hidden = False
If [B1] = "Cuve" Then Rows(3).Hidden = True _
  Else If [B1] = "Code" Then Rows(2).Hidden = True
col = IIf([B1] = "Cuve", 2, 8)
critere = IIf([B1] = "Cuve", "C" & [B2], "*" & [B3] & "*")
'---mise en forme du tableau et filtrage---
P.Offset(1).Resize(n) = rest 'restitution
ListObjects(1).Resize P.Resize(n + 1) 'redimensionnement
With ListObjects(1).Range
  .Sort .Columns(1), xlAscending, Header:=xlYes 'tri
  .AutoFilter 1
  If [B1] <> "" And (col = 2 And [B2] <> "" Or col = 8 And [B3] <> "") _
    Then .AutoFilter col, critere
End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [B1:B3]) Is Nothing Then Worksheet_Activate
End Sub