Private Sub Worksheet_Activate()
Dim d1 As Object, d2 As Object, resu(), tablo, i&, n&, x$, y$, lig&, c As Range
Set d1 = CreateObject("Scripting.Dictionary")
d1.CompareMode = vbTextCompare 'la casse est ignorée
Set d2 = CreateObject("Scripting.Dictionary")
d2.CompareMode = vbTextCompare 'la casse est ignorée
ReDim resu(1 To Rows.Count, 1 To 5)
tablo = Feuil1.[B2].CurrentRegion.Resize(, 3) 'matrice, plus rapide
For i = 2 To UBound(tablo)
n = n + 1
x = Trim(tablo(i, 1))
resu(n, 1) = x
resu(n, 2) = tablo(i, 2)
resu(n, 3) = tablo(i, 3)
d1(x) = d1(x) + 1 'compte
d2(x & Chr(1) & d1(x)) = n 'repère la ligne
Next
tablo = Feuil2.[B2].CurrentRegion.Resize(, 4) 'matrice, plus rapide, 1 colonne de plus pour le repérage
d1.RemoveAll 'RAZ
For i = 2 To UBound(tablo)
x = Trim(tablo(i, 1))
d1(x) = d1(x) + 1 'compte
y = x & Chr(1) & d1(x)
If d2.exists(y) Then
resu(d2(y), 4) = tablo(i, 2)
resu(d2(y), 5) = tablo(i, 3)
tablo(i, 4) = d2(y) 'repère le numéro de ligne
Else
tablo(i, 4) = ""
End If
Next
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [B3] '1ère cellule de restitution, à adapter
If n Then .Resize(n, 5) = resu
.Resize(Rows.Count - .Row + 1, 5).Font.Bold = False 'non gras
.Offset(n).Resize(Rows.Count - n - .Row + 1, 5).ClearContents 'RAZ en dessous
'---insertion des lignes du 2ème bilan non traitées---
For i = 2 To UBound(tablo)
If tablo(i, 4) = "" Then
lig = Val(tablo(i - 1, 4)) + 1
If lig > 1 Then .Cells(lig, 1).Resize(, 5).Insert xlDown
.Cells(lig, 1) = tablo(i, 1)
.Cells(lig, 4) = tablo(i, 2)
.Cells(lig, 5) = tablo(i, 3)
tablo(i, 4) = lig 'repère le numéro de ligne
n = n + 1
End If
Next
'---traitement de la ligne Bilan---
If n Then Set c = .Resize(n).Find("Bilan", , xlValues, xlWhole)
If Not c Is Nothing Then
c.Resize(, 5).Cut
.Offset(n).Insert
.Offset(n - 1).Font.Bold = True 'gras
End If
End With
With UsedRange: End With 'actualise les barres de défilement
End Sub