Private Sub Worksheet_Activate()
Dim d As Object, tablo, i&, x$, a, b
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
tablo = Feuil1.[A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide
For i = 2 To UBound(tablo)
x = tablo(i, 1)
If Not d.exists(x) Then d(x) = UCase(tablo(i, 2))
If UCase(tablo(i, 2)) <> d(x) Then d(x) = "MULTI"
Next i
If d.Count Then
a = d.keys: b = d.items
For i = 0 To UBound(a)
tablo(i + 1, 1) = a(i)
x = b(i)
If x <> "MULTI" Then x = "MONO"
tablo(i + 1, 2) = x
Next i
End If
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] '1ère cellule de destination, à adapter
i = d.Count
If i Then
.Resize(i, 2) = tablo
.Resize(i, 2).Interior.ColorIndex = 19 'jaune clair
.Resize(i, 2).Borders.Weight = xlHairline 'bordures
End If
.Offset(i).Resize(Rows.Count - i - .Row + 1, 2).Delete xlUp 'RAZ en dessous
End With
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub