Private Sub Worksheet_Activate()
Dim resu(), d As Object, w As Worksheet, trouve As Boolean, tablo, i&, col%, x$, n&
ReDim resu(1 To Rows.Count, 1 To 1 + Worksheets.Count)
'---remplissage du tableau des résultats---
resu(1, 1) = "N°": resu(1, 2) = "Intitulé": n = 1
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For Each w In Worksheets
If w.Name <> Me.Name Then
trouve = False
tablo = w.UsedRange.Columns(1).Resize(, 4) 'matrice, plus rapide
For i = 1 To UBound(tablo)
If IsError(tablo(i, 1)) Then
If Not trouve Then trouve = True: col = col + 1: resu(1, col + 2) = w.Name
x = tablo(i, 2) & tablo(i, 3)
If Not d.exists(x) Then
n = n + 1
d(x) = n 'mémorise le numéro de ligne
resu(n, 1) = tablo(i, 2)
resu(n, 2) = tablo(i, 3)
End If
If IsNumeric(tablo(i, 4)) Then resu(d(x), col + 2) = resu(d(x), col + 2) + CDbl(tablo(i, 4)) 'somme
End If
Next
End If
Next
'---restitution---
Application.ScreenUpdating = False
Cells.Delete 'RAZ
With [A3].Resize(n, col + 2) 'cellule à adapter
.Value = resu
If col Then .Columns(3).Resize(, col).NumberFormat = "#,##0.00"
.Borders.Weight = xlThin 'bordures
.Rows(1).Interior.ColorIndex = 5 'bleu
.Rows(1).Font.ColorIndex = 2 'blanc
.Rows(1).Font.Bold = True 'gras
.Columns.AutoFit 'ajustement largeurs
End With
End Sub