Dim a, d As Object, i As Long, x As String, y As String
Set d = CreateObject("scripting.dictionary")
Sheets("BDD").Range([Q2], [Q65536].End(xlUp)).ClearContents
a = Sheets("BDD").[A1].CurrentRegion
x = UCase("main") ' d'oeuvre") 'le oe de oeuvre pose problème
For i = 2 To UBound(a)
y = UCase(Left(a(i, 1), Len(x)))
If y = x Then d(a(i, 3)) = a(i, 3)
Next i
Sheets("BDD").[Q2].Resize(d.Count) = Application.Transpose(d.Items)