Seçime Göre Sıralama

[DeliBalta58]

Ekteki dosyamda Sayfa1 de Sıralama yapmak istediğim Unvarlar mevcut. ( Bu sıra çok sık değişmekte ).
Sayfa2 de ise İsim listem var.
Sayfa3 e ise;
1. olarak Sayfa1 de yazdığım unvan sıralamasına göre,
2. olarak ta D sütununda bulunan sayılar baz alınarak küçükten büyüğe doğru sıralama yaptıktan sonra sıra numarasını yeniden vermek istiyorum.
Yardımlarınız için şimdiden Teşekkürler.

 

[Emir Hüseyin Çoban]

. . .

Sayfa1 B sütununa dikkat.

. . .

 

[baydeniro]

Teşekkürler.

 

[Necdet]

Merhaba,

Seçenek olsun.

Sub Ozel_SIRALA()
    
    Dim i   As Long, _
        j   As Long, _
        Son As Integer, _
        Kol As Integer, _
        c   As Range, _
        s1  As Worksheet, _
        s2  As Worksheet
    
    Application.ScreenUpdating = False
    
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    
    Son = s1.Cells(Rows.Count, "A").End(3).Row
    
'Unvanlara Numara Veriliyor ---------------
    s1.Range("B:B").ClearContents
    s1.Range("B2") = 1
    s1.Range("B2:B" & Son).DataSeries
'Unvanlara Numara Verildi -----------------
    
    Kol = s2.Cells(1, Columns.Count).End(1).Column + 1  'Sayfa2 nin Son Boş Kolon Sayısı Bulundu
    j = s2.Cells(Rows.Count, "B").End(3).Row            'Sayfa2 nin Son Satır Numarası
    
    'Sayfa2 de Son Boş kolona sayfa1 deki unvan numaraları yazdırılıyor
    For i = 2 To j
        Set c = s1.Range("A2:A" & Son).Find(s2.Cells(i, "E"), LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            s2.Cells(i, Kol) = c.Offset(0, 1)
        Else
            s2.Cells(i, Kol) = 0
        End If
    'Unvan Numaraları Yazdırıldı
    Next i
    
    'Sayfa2 Yardımcı Sütun ve D sütununa göre sıralanıyor
    s2.Range(s2.Cells(2, "A"), s2.Cells(j, Kol)).Sort Key1:=s2.Cells(1, Kol), Key2:=s2.Range("D1")
    'Yardımcı Sütun Siliniyor
    s2.Columns(Kol).Delete
    'Yeniden Sıra Numarası Veriliyor
    s2.Range("A2") = 1
    s2.Range("A2:A" & j).DataSeries
    
    Application.ScreenUpdating = True
    
    MsgBox "SIRALAMA YAPILMIŞTIR...", vbInformation, "Necdet YEŞERTENER"
    
End Sub

 

[DeliBalta58]

Her İkinize de ayrı ayrı teşekkürler