3 adet dosya var deneyebilirsiniz istiyorsanız.
Dosyayı buraya yükleyemedim çünkü dosya ekleme yeri çıkmadı birtürlü.
https://www.dosyaupload.com/70l4
Kod:
For i = 1 To say
For j = i To say
If arr(i, 1) > arr(j, 1) Then
Temp = arr(j, 1)
arr(j, 1) = arr(i, 1)
arr(i, 1) = Temp
End If
Next j
Next iKod:
Private Sub CommandButton1_Click()
Dim i As Long, j As Long, k As Long
Dim Temp As Long
Dim scr As Object
Dim say As Long, arr()
List = Range("A3:A" & Cells(Rows.Count, 1).End(3).Row).Value
Set scr = CreateObject("Scripting.Dictionary")
With scr
ReDim arr(1 To UBound(List), 1 To 1)
On Error Resume Next
For k = LBound(List) To UBound(List)
If Not .Exists(List(k, 1)) Then
.Add List(k, 1), ""
say = say + 1
arr(say, 1) = List(k, 1)
End If
Next
[D:D] = ""
Err.Clear
If say > 0 Then
For i = 1 To say
For j = i To say
If arr(i, 1) > arr(j, 1) Then
Temp = arr(j, 1)
arr(j, 1) = arr(i, 1)
arr(i, 1) = Temp
End If
Next j
Next i
Range("D3").Resize(say, 1).Value = arr
End If
End With
MsgBox "Bitti..", vbInformation
Erase List: Set scr = Nothing: Erase arr
End Sub