Option Explicit
Sub test()
Dim arr, i, j, t, m
arr = Range("b2:b" & Cells(Rows.Count, "b").End(xlUp).Row + 1)
ReDim brr(1 To UBound(arr, 1) * 2, 1 To 1)
For i = 1 To UBound(arr, 1) - 2
For j = i + 1 To UBound(arr, 1) - 1
If arr(i, 1) > arr(j, 1) Then
t = arr(i, 1): arr(i, 1) = arr(j, 1): arr(j, 1) = t
End If
Next
Next
For i = 1 To UBound(arr, 1) - 1
m = m + 1: brr(m, 1) = arr(i, 1)
If arr(i, 1) <> arr(i + 1, 1) Then m = m + 1
Next
With [d2]
.Resize(Rows.Count - 1).ClearContents
.Resize(UBound(brr, 1)) = brr
End With
End Sub |