negatif pozitif değere göre Sıralama Makrosu

[buggsbunny]

Merhaba şölye bir sorum var. İllerin oranları ile ilgili bir tablom var. Bu tabloda sıralama yaparken negatif olanları kendi içinde küçükten büyüğe, pozitif olanları da sıfır olan değerler de dahil kendi içinde büyükten küçüğe sıralaması istiyorum. Bunu nasıl yapabilirim.
Yeni Microsoft Excel Çalışma Sayfası (2).xlsx - 8 KB

 

[Muzaffer Ali]

Merhaba.
Görmek istediğiniz sonucu da ekleyerek örnek dosyanızı yeniden paylaşın.

 

[Necdet]

Merhaba,
Yeni bir sütuna , örneğin C sütununa

=EĞER(B2< 0;0;EĞER(B2=0;1;2))

formül yazıp bu sütuna göre sıralamada bu sütun ikinci sıralamayı da B sütuna göre yaptırabilirsiniz.

 

[buggsbunny]

Merhaba.
Görmek istediğiniz sonucu da ekleyerek örnek dosyanızı yeniden paylaşın.

 

[Muzaffer Ali]

Aşağıdaki kodu deneyin.

Sub Test()
    Dim SonSatir As Long, Bak As Long
    With ThisWorkbook.Worksheets("Sayfa1")
        .Sort.SortFields.Clear
        .Sort.SortFields.Add2 Key:=Range("B:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        
        .Sort.SetRange Range("A:B")
        .Sort.Header = xlYes
        .Sort.MatchCase = False
        .Sort.Orientation = xlTopToBottom
        .Sort.SortMethod = xlPinYin
        .Sort.Apply

        SonSatir = .Cells(.Rows.Count, "A").End(xlUp).Row
        For Bak = 2 To SonSatir
            If .Cells(Bak, "B") >= 0 Then Exit For
        Next

        .Sort.SortFields.Clear
        .Sort.SortFields.Add2 Key:=Range("B" & Bak & ":B" & SonSatir), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .Sort.SetRange Range("A" & Bak & ":B" & SonSatir)
        .Sort.Header = xlGuess
        .Sort.MatchCase = False
        .Sort.Orientation = xlTopToBottom
        .Sort.SortMethod = xlPinYin
        .Sort.Apply
    End With
End Sub

 

[buggsbunny]

Aşağıdaki kodu deneyin.

Sub Test()
    Dim SonSatir As Long, Bak As Long
    With ThisWorkbook.Worksheets("Sayfa1")
        .Sort.SortFields.Clear
        .Sort.SortFields.Add2 Key:=Range("B:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
       
        .Sort.SetRange Range("A:B")
        .Sort.Header = xlYes
        .Sort.MatchCase = False
        .Sort.Orientation = xlTopToBottom
        .Sort.SortMethod = xlPinYin
        .Sort.Apply

        SonSatir = .Cells(.Rows.Count, "A").End(xlUp).Row
        For Bak = 2 To SonSatir
            If .Cells(Bak, "B") >= 0 Then Exit For
        Next

        .Sort.SortFields.Clear
        .Sort.SortFields.Add2 Key:=Range("B" & Bak & ":B" & SonSatir), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .Sort.SetRange Range("A" & Bak & ":B" & SonSatir)
        .Sort.Header = xlGuess
        .Sort.MatchCase = False
        .Sort.Orientation = xlTopToBottom
        .Sort.SortMethod = xlPinYin
        .Sort.Apply
    End With
End Sub

Office 2019 kullanıyorum, kodu yazdım ama hareketlilik yok

 

[Muzaffer Ali]

Kodu bir modüle kopyalayın. Mouse imlecini kodun herhangi bir yerine getirin yada seçin F5 tuşuna basarak kodu çalıştırın.

 

[buggsbunny]

Office 2019 kullanıyorum, kodu yazdım ama hareketlilik yok

Office 2019 kullanıyorum, kodu yazdım ama hareketlilik yok

ufak bie değişiklikle halloldu teşekkürler

 

[Necdet]

Alternatif olsun

Sub Makro1()

    Dim i   As Long
    
    Application.ScreenUpdating = False
    
    i = Cells(Rows.Count, "A").End(3).Row
    Range("C1") = Application.WorksheetFunction.Max(Range("B2:B" & i))
    
    Range("C2").FormulaR1C1 = _
        "=IF(RC[-1]<0,""A"",IF(RC[-1]>0,""B ""&R1C3-RC[-1],""C""))"
    Range("C2:C" & i).FillDown
    
    Range("A2:C" & i).Sort Key1:=[C2], order1:=xlAscending, Key2:=[B1], order2:=xlAscending
    Range("C1:C" & i).Clear
    Application.ScreenUpdating = True
    
End Sub

 

[buggsbunny]

Peki bunu sadece a2 ile b12 arasına uygulayabilir miyiz? çünkü alt satırlarda da veri var

 

[Muzaffer Ali]

Kodları inceleseniz aslında rahatlıkla çözebilirsiniz.
Değişken adları anlaşılabilecek şekilde tanımlanmıştır.

SonSatir = .Cells(.Rows.Count, "A").End(xlUp).Row

Yerine

SonSatir =12

yazın.