Private Sub Worksheet_Activate()
Dim f, ncol%, d As Object, j%, c As Range, x$, y$, z$, n&, nn&, a(), b(), i&
f = Array("Lot 1", "Lot 2") 'liste des feuilles à traiter
ncol = UBound(f) + 3
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For j = 3 To ncol
For Each c In Sheets(f(j - 3)).UsedRange
If IsNumeric(CStr(c)) Then
x = "": y = ""
If c.Column > 2 Then x = c(1, -1).MergeArea(1)
If c.Column > 1 Then y = c(1, 0).MergeArea(1)
If y = "" Then y = c(1, 2)
If x = y Then x = ""
If x = "" Then x = "finale" 'pourquoi ne pas laisser vide ?
z = x & y
If Not d.exists(z) Then
n = n + 1
d(z) = n 'mémorise le numéro de ligne
ReDim Preserve a(1 To ncol, 1 To n) 'tableau transposé
End If
nn = d(z) 'récupère le numéro de ligne
a(1, nn) = x
a(2, nn) = y
a(j, nn) = c
End If
Next c, j
'---transposition---
If n Then
ReDim b(1 To n, 1 To ncol)
For i = 1 To n
For j = 1 To ncol
b(i, j) = a(j, i)
Next j, i
End If
'---restitution---
With ListObjects(1).Range
If .Columns.Count > ncol Then .Cells(1, ncol + 1).Resize(, .Columns.Count - ncol) = ""
For j = 3 To ncol: .Cells(1, j) = f(j - 3): Next j
If n Then .Cells(2, 1).Resize(n, ncol) = b
If .Rows.Count > n + 1 Then .Rows(n + 2).Resize(.Rows.Count - n - 1).ClearContents 'RAZ en dessous
.ListObject.Resize .Resize(IIf(n, n + 1, 2), ncol) 'redimensionnement du tableau
End With
End Sub