Option Compare Text 'la casse est ignorée
Sub MAJ_Feuil2()
Dim t, c As New Collection, cc As New Collection, P As Range, tablo, ub%, resu(), i&, dat As Variant, x$, j%, y$, lig&, col%(), k%, ubcol%
t = Timer
'---analyse de Feuil2---
Set P = Sheets("Feuil2").UsedRange.Resize(, 26)
tablo = P 'matrice, plus rapide
ub = UBound(tablo, 2)
ReDim resu(1 To UBound(tablo) - 1, 1 To ub - 12)
On Error Resume Next 'nécessaire avec les collections
For i = 2 To UBound(tablo)
dat = tablo(i, 12)
If IsDate(dat) Then cc.Add "", tablo(i, 1) & Chr(1) & dat
x = Chr(1) & tablo(i, 2) & Chr(1) & tablo(i, 12)
For j = 13 To ub
y = tablo(i, 1) & Chr(1) & tablo(1, j) & x
c.Add "", y
resu(i - 1, j - 12) = y
Next j, i
'---analyse de Feuil1---
tablo = Sheets("Feuil1").UsedRange 'matrice, plus rapide
ub = UBound(tablo, 2)
lig = 1
For i = 2 To UBound(tablo)
x = tablo(i, 1)
If x <> "" Then
If tablo(i - 1, 1) = "" Then lig = i 'ligne des dates
If i > lig Then
If i = lig + 1 Then
k = 0
'---mémorise les colonnes à utiliser pour gagner du temps---
For j = 4 To ub
If cc(x & Chr(1) & tablo(lig, j)) <> "" Then Else ReDim Preserve col(k): col(k) = j: k = k + 1
Next j
ubcol = UBound(col)
End If
x = x & Chr(1) & tablo(i, 2) & Chr(1) & tablo(i, 3) & Chr(1)
For k = 0 To ubcol
y = x & tablo(lig, col(k))
If c(y) <> "" Then Else c.Remove y: c.Add tablo(i, col(k)), y 'mémorise la valeur
Next k
End If
End If
Next i
'---résultats---
ub = UBound(resu, 2)
For i = 1 To UBound(resu)
For j = 1 To ub
resu(i, j) = c(resu(i, j))
Next j, i
P(2, 13).Resize(UBound(resu), ub) = resu 'restitution sur la feuille
MsgBox "MAJ réalisée en " & Format(Timer - t, "0.00 \sec")
End Sub