XL 2016 Reporter des lignes de plusieurs feuilles

Private Sub Worksheet_Activate()
Dim col, d As Object, w As Worksheet, P As Range, t, j%, a, b, ub%, i&, n&, resu()
col = Array("B", "C") 'liste des colonnes, à adapter
Set d = CreateObject("Scripting.Dictionary")
For Each w In Worksheets
    If w.Name <> Me.Name Then
        Set P = w.[A1].CurrentRegion
        t = P.Resize(P.Rows.Count + 1) 'matrice, plus rapide, au moins 2 éléments
        For j = 1 To UBound(t, 2)
            If IsNumeric(Application.Match(t(1, j), col, 0)) Then d(t(1, j)) = j 'mémorise la colonne
        Next j
        If d.Count Then
            a = d.keys: b = d.items: ub = UBound(a)
            For i = 2 To UBound(t) - 1
                For j = 0 To ub
                    If t(i, b(j)) <> "" Then
                        n = n + 1
                        ReDim Preserve resu(1 To 3, 1 To n)
                        resu(1, n) = t(i, 1)
                        resu(2, n) = a(j)
                        resu(3, n) = t(i, b(j))
                    End If
            Next j, i
            d.RemoveAll 'RAZ du Dictionary
        End If
    End If
Next w
If n Then
    '---transposition---
    ReDim t(1 To n, 1 To 3)
    For i = 1 To n
        For j = 1 To 3
            t(i, j) = resu(j, i)
    Next j, i
    '---restitution---
    If FilterMode Then ShowAllData 'si la feuille est filtrée
    [A2].Resize(n, 3) = t
End If
[A2].Offset(n).Resize(Rows.Count - n - 1, 3).ClearContents 'RAZ sous le tableau
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Private Sub Worksheet_Activate()
Dim col, d As Object, w As Worksheet, P As Range, colLibel As Variant, colDate As Variant, t, j%, a, b, ub%, i&, n&, resu()
col = Array("F", "G", "H", "I") 'liste des colonnes, à adapter
Set d = CreateObject("Scripting.Dictionary")
For Each w In Worksheets
    If w.Name <> Me.Name Then
        Set P = w.[A1].CurrentRegion
        colLibel = Application.Match("Libellé", P.Rows(1), 0)
        colDate = Application.Match("Date", P.Rows(1), 0)
        t = P.Resize(P.Rows.Count + 1) 'matrice, plus rapide, au moins 2 éléments
        For j = 1 To UBound(t, 2)
            If IsNumeric(Application.Match(t(1, j), col, 0)) Then d(t(1, j)) = j 'mémorise la colonne
        Next j
        If d.Count Then
            a = d.keys: b = d.items: ub = UBound(a)
            For i = 2 To UBound(t) - 1
                For j = 0 To ub
                    If t(i, b(j)) <> "" Then
                        n = n + 1
                        ReDim Preserve resu(1 To 4, 1 To n)
                        If IsNumeric(colDate) Then resu(1, n) = t(i, colDate) Else resu(1, n) = ""
                        If IsNumeric(colLibel) Then resu(2, n) = t(i, colLibel) Else resu(2, n) = ""
                        resu(3, n) = a(j)
                        resu(4, n) = t(i, b(j))
                    End If
            Next j, i
            d.RemoveAll 'RAZ du Dictionary
        End If
    End If
Next w
If n Then
    '---transposition---
    ReDim t(1 To n, 1 To 4)
    For i = 1 To n
        For j = 1 To 4
            t(i, j) = resu(j, i)
    Next j, i
    '---restitution---
    If FilterMode Then ShowAllData 'si la feuille est filtrée
    [A2].Resize(n, 4) = t
End If
[A2].Offset(n).Resize(Rows.Count - n - 1, 4).ClearContents 'RAZ sous le tableau
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub