بارك الله قيك اخي الفاضل رجب
 
	و اسمح لي باضاقة بسيطة على الكود ليتجنب التكرار و يصبح هكذا
 
Sub Transpose_RG1()
Dim i As Integer
Dim ii As Integer
Dim LR As Integer
Dim arr() As Variant
'=============================================================
[B1:B1000].ClearContents
LR = Cells(Rows.Count, 1).End(xlUp).Row
'=============================================================
For i = LR To 1 Step -1
 x = Application.WorksheetFunction.CountIf(Range("a1:a" & i), Cells(i, 1))
 If x > 1 Or Cells(i, 1) = Empty Then GoTo 1
        ii = ii + 1
        ReDim Preserve arr(1 To ii)
        arr(ii) = Cells(i, 1)
1:
Next
[B1].Resize(ii) = Application.WorksheetFunction.Transpose(arr)
End Sub