Sub PList() Dim i&, Myr&, Arr Range("B:B").Clear Application.ScreenUpdating = False Myr = Sheet1.[A65536].End(xlUp).Row Arr = Sheet1.Range("A1:A" & Myr) For i = 2 To UBound(Arr) If Arr(i, 1) <> Arr(i - 1, 1) Then Cells(i, 2) = Arr(i, 1) End If Next Application.ScreenUpdating = True End Sub