Private Sub CommandButton1_Click()
Set liste = CreateObject("scripting.dictionary")
Dim tabloColD()
Dim tabloLignes()
tablo = Range("A5:C" & Cells(Rows.Count, 1).End(xlUp).Row)
ReDim tabloColD(1 To UBound(tablo), 1 To 1)
For i = 1 To UBound(tablo)
If tablo(i, 1) <> "" And Not liste.exists(tablo(i, 1)) Then
ReDim tabloLignes(0)
lig = 0
dif = False
For x = i To UBound(tablo)
If tablo(x, 1) = tablo(i, 1) Then
If tablo(x, 2) = tablo(x, 3) Then
ReDim Preserve tabloLignes(lig)
tabloLignes(lig) = x
lig = lig + 1
Else
dif = True
Exit For
End If
End If
Next x
If Not dif Then
For k = 0 To UBound(tabloLignes)
tabloColD(tabloLignes(k), 1) = [F1].Value
Next k
End If
liste(tablo(i, 1)) = ""
End If
Next i
Range("D5:D" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
[D5].Resize(UBound(tablo), 4) = tabloColD
End Sub