diziyi sayfaya alfabetik sırala

[şehiriçi]

Merhaba arkadaşlar,
ekteki dosyamda , bloklar sayfasındaki range("A3:Q22") arasındaki veriler benzersiz bir şekilde duraklar sayfasında Bir sütununa Alfabetik olarak sıralamak istiyorum .
Bir yere kadar geldi ancak sonuca ulaşamadım . Bu noktada desteğinize ihtiyacım var ,teşekkürler

 

[Greenblacksea53]

Sub BenzersizVerileriListele()
    Dim wsBloklar As Worksheet
    Dim wsDuraklar As Worksheet
    Dim SonSatir As Long
    Dim cell As Range, destCell As Range
    

    Set wsBloklar = ThisWorkbook.Sheets("Bloklar")
    Set wsDuraklar = ThisWorkbook.Sheets("Duraklar")
    
    SonSatir = 23
    
    Set destCell = wsDuraklar.Range("A3")
    
  
    For Each cell In wsBloklar.Range("A3:Q" & SonSatir)
        
        If cell.Value <> "" And cell.Row > 2 Then
            
            If WorksheetFunction.CountIf(wsDuraklar.Range("A:A"), cell.Value) = 0 Then
              
                destCell.Value = cell.Value
              
                Set destCell = destCell.Offset(1, 0)
            End If
        End If
    Next cell
    
     Columns("A:A").Select
    ActiveWorkbook.Worksheets("duraklar").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("duraklar").Sort.SortFields.Add Key:=Range("A3:A53" _
        ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("duraklar").Sort
        .SetRange Range("A3:A53")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Select
    
    
End Sub

Bu kodları mödüle ekleyip butona atayabilirsiniz..

 

[şehiriçi]

Eline Emegi'ne Sağlık Teşekkürler Greenblacksea53

 

[Necdet]

Merhaba,
Alternatif olsun.

Public Sub Tek()

'Tools Referanslardan Microsoft Scripting Runtime SEÇİLİ OLMALI
Dim arr As Variant
Dim r   As Long
Dim c   As Long
Dim dict As New Scripting.Dictionary

Application.ScreenUpdating = False

arr = Sayfa1.Range("A1").CurrentRegion.Value

For r = 3 To UBound(arr, 1)
    For c = LBound(arr, 2) To UBound(arr, 2)
        If Not dict.Exists(arr(r, c)) Then
            dict.Add arr(r, c), ""
        End If
    Next c
Next r

Sayfa2.Select
Range("A1").CurrentRegion.ClearContents
Range("A1").Resize(dict.Count, 1) = _
        Application.WorksheetFunction.Transpose(dict.Keys)
Range("A1:A" & dict.Count).Sort Key1:=[A1]

Application.ScreenUpdating = True

End Sub

 

[veyselemre]

Sub test()
    Dim veri, v, i, ii
    veri = Sheets("Bloklar").Range("A3:Q22").Value

    With CreateObject("Scripting.Dictionary")
        For Each v In veri
            If WorksheetFunction.Proper(v) <> "" Then .Item(WorksheetFunction.Proper(v)) = Null
        Next v
        veri = .keys
    End With

    For i = LBound(veri) To UBound(veri) - 1
        For ii = i + 1 To UBound(veri)
            If StrComp(veri(i), veri(ii), vbTextCompare) = 1 Then
                v = veri(i)
                veri(i) = veri(ii)
                veri(ii) = v
            End If
        Next ii
    Next i

    With Sheets("Duraklar")
        veri = Application.Transpose(veri)
        .Range("A3:A" & Rows.Count).ClearContents
        .Range("A3").Resize(UBound(veri)).Value = veri
    End With

End Sub

Sub test2()
    Dim veri, v
    veri = Sheets("Bloklar").Range("A3:Q22").Value

    With CreateObject("Scripting.Dictionary")
        For Each v In veri
            If WorksheetFunction.Proper(v) <> "" Then .Item(WorksheetFunction.Proper(v)) = Null
        Next v
        veri = Application.Transpose(.keys)
    End With

    With Sheets("Duraklar")
        .Range("A3:A" & Rows.Count).ClearContents
        With .Range("A3").Resize(UBound(veri))
            .Value = veri
            .Sort .Cells(1)
        End With
    End With

End Sub