Private Sub Worksheet_Change(ByVal Target As Range)
Dim dest As Range, d As Object, tablo, e, x$, a, b$(), i&
Set dest = [J3] '1ère cellule de destination, à adapter
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
tablo = Range("A3:G" & Cells.SpecialCells(xlCellTypeLastCell).Row).Value2 'matrice, plus rapide
For Each e In tablo
x = Trim(CStr(e))
If x <> "" Then If Not IsNumeric(x) Then d(x) = "" 'liste sans doublon
Next
Application.EnableEvents = False 'désactive les évènements
If d.Count Then
a = d.keys
ReDim b(UBound(a), 0) 'base 0
For i = 0 To UBound(a): b(i, 0) = a(i): Next 'transposition
With dest.Resize(d.Count)
.Value = b 'restitution
.Interior.Color = RGB(255, 255, 204) 'jaune clair
End With
End If
dest.Offset(d.Count).Resize(Rows.Count - d.Count - dest.Row + 1).Clear 'RAZ en dessous
Application.EnableEvents = True 'réactive les évènements
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub