Döngü ile Aralık Seçerek Sıralama Yapmak

[maviada5]

Merhaba forum üyeleri,
Netcad Programının kullandığı verilerde sıralama yaptırmak istiyorum, ben epey uğraştım ama yapamadım.

Veri tanımı:

1 ile başlayan satırlar kilometre satırıdır sıralamaya dahil olmayacaktır.
0 ile başlayan satırlar sıralama yaptırılacak, ama

Yapmak istediğim:
1 ile başlayan satırı atlayıp ikinici 1 ile başlayan sıtır arasında kalan 0 ile başlayan aralıktaki alanı seçip c sütunu değerine göre artan sıralama yaptıracak, ve sonraki 0 ile başlayan alanı bulup aynı işlemi yapacak

Şimdiden teşekkürler.

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub Sartli_Sirala()

    Dim son As Long, i As Long, c As Range

    son = Cells(Rows.Count, "B").End(xlUp).Row

    For i = 10 To son
        Set c = Range("B" & i & ":B" & son).Find(1, , xlValues, xlWhole)
        If Not c Is Nothing Then
            Range("B" & i & ":E" & c.Row - 1).Sort _
                Key1:=Range("C" & i - 1), Order1:=xlAscending
            i = c.Row
        Else
            Range("B" & i & ":E" & son).Sort _
                Key1:=Range("C" & i - 1), Order1:=xlAscending
            Exit Sub
        End If
    Next i
    
End Sub

.

 

[maviada5]

Merhaba Ömer bey, kodu çalıştırdım oldu, fakat siz 10. satırdan başlatmışsınız ben 2 satırdan başlattım. Çünkü bendeki bazı veriler 1 satırdan başlıyor, denedim sıkınyı yok.
İlaveten sayaç koyup kaç sıralama yaptıpını bulmak istedim ama Mesaj kutusu ekrana gelmeden sıralama işlemi bitiyor, aslında çok önemli değil ama uğraştırmayacaksa ekleyebilir misiniz.

sırala()
Dim son As Long, i As Long, c As Range
Dim say As Long
say = 0

    son = Cells(Rows.Count, "B").End(xlUp).Row

    For i = 2 To son
        Set c = Range("B" & i & ":B" & son).Find(1, , xlValues, xlWhole)

        If Not c Is Nothing Then
            Range("B" & i & ":E" & c.Row - 1).Sort _
                Key1:=Range("C" & i - 1), Order1:=xlAscending
                i = c.Row
                say = say + 1
        Else
            Range("B" & i & ":E" & son).Sort _
                Key1:=Range("C" & i - 1), Order1:=xlAscending
                    say = say + 1
            Exit Sub
        End If
    Next i
    
MsgBox "Sıralama İşlemi Bitti. " & say & " Adet Kesit Sıralandı"             '   mesaj ekle
End Sub

 

[Ömer]

MsgBox satırını kodlarda bulunan "Exit Sub" satırından önce ilave ederek deneyin.

.

 

[maviada5]

Çok teşekkür ederim Ömer Bey, iyi çalışmalar dilerim.