Dizi ile çok kriterli sıralama

[Muhammet Okumuş]

Arkadaşlar merhaba, Çok aradım ama istediğime ulaşamadım.

Sub Sırala()
tablo = Range("D4:I11").Value
For i = 1 To UBound(tablo) - 1
For j = i + 1 To UBound(tablo)
If tablo(j, 6) < tablo(i, 6) Then
ReDim x(1 To 8, 1 To 6)
For k = 1 To 6
x(i, k) = tablo(i, k)
tablo(i, k) = tablo(j, k)
tablo(j, k) = x(i, k)
Next k

End If

Next
Next
Range("S4").Resize(8, 6) = tablo
End Sub

Bu kod ile son ölçütü sıralayabiliyorum. Kod yapısını doğru olmayabilir.

6 ölçütü küçükten büyüğe, Adan Z'ye nasıl sıralayabilirim.

Soldaki tabloyu sağdakine dizi yöntemi ile nasıl getirebiliriz.

 

[Korhan Ayhan]

Sıralama için alternatif bir çözüm belki kullanmak istersiniz diye paylaşmak istedim.

Kodun çalışması için eğer sisteminizde yüklü değilse linkteki yüklemeyi yapmanız gerekiyor.

Download Microsoft .NET Framework 3.5 from Official Microsoft Download Center

Microsoft .NET Framework 3.5, .NET Framework 2.0 ve 3.0 üzerine inşa edilmiş birçok yeni özellik içermesi yanında, .NET Framework 2.0 Service Pack 1'i ve .NET Framework 3.0 Service Pack 1'i içerir.

www.microsoft.com

Option Explicit

Sub Sorting_Table()
    Dim My_Data As Variant, X As Long, Y As Integer
   
    Application.ScreenUpdating = False
   
    My_Data = Range("D4:I11").Value
   
    Range("L4:Q11").ClearContents
   
    ReDim My_List(1 To UBound(My_Data, 1), 1 To 1)
   
    With CreateObject("System.Collections.ArrayList")
        For X = LBound(My_Data, 1) To UBound(My_Data, 1)
            For Y = 1 To UBound(My_Data, 2)
                My_List(X, 1) = IIf(Y = 1, My_Data(X, Y), My_List(X, 1) & " " & My_Data(X, Y))
            Next
            If Not .Contains(My_List(X, 1)) Then .Add My_List(X, 1)
        Next
        .Sort
        Range("L4").Resize(.Count) = Application.Transpose(.ToArray())
        Application.DisplayAlerts = False
        Range("L4").Resize(.Count).TextToColumns Destination:=Range("L4"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(0, 1), Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1)), TrailingMinusNumbers:=True
        Application.DisplayAlerts = True
    End With
   
    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır."
End Sub

 

[Muhammet Okumuş]

Korhan hocam çok teşekkür ederim. Göndermiş olduğunuz kod yapısı çok karmaşık geldi. Dosyama uyarlamaya çalışacağım.
Bir soru sormak istiyorum.

Sub Sırala()
tablo = Range("D4:I11").Value
For i = 1 To UBound(tablo) - 1
For j = i + 1 To UBound(tablo)
If tablo(j, 6) < tablo(i, 6) Then
ReDim x(1 To 8, 1 To 6)
For k = 1 To 6
x(i, k) = tablo(i, k)
tablo(i, k) = tablo(j, k)
tablo(j, k) = x(i, k)
Next k
End If
Next
Next
Range("S4").Resize(8, 6) = tablo
End Sub

Bu kod yapısına aşina olduğum için bu kod yapısına benzer bir sıralama yapamaz mıyız?

 

[Korhan Ayhan]

Karışık bir durum yok aslında..

Önce satırdaki verileri birleştiriyoruz. Sonra bunları bir diziye yüklüyoruz. Sonra sıralıyor ve hücreye yazdırıyoruz.

En son aşamada ise "Metni Sütunlara Dönüştür" işlemi ile verileri tekrar hücrelere ayrıştırıyoruz.

Sıralama işlemi için en bilinen metod "Bubble Sort" tekniğidir.

Nette arama yaparsanız bolca örneğe ulaşabilirsiniz. Videolar bile var.

 

[Muhammet Okumuş]

Tamam Korhan Hocam bu tekniği araştıracağım. Çok teşekkür ederim. Bu yöntem de diziler kadar hızlı o zaman.

 

[Korhan Ayhan]

Bahsettiğiniz "Bubble Sort" tekniği ise benim ulaştığım linklerde büyük verilerde performans beklemeyin diyor. Yani nispeten küçük verilerde kullanılmasını tavsiye etmişler.

Benim önerim nispeten hızlıdır...

Belki ADO ile daha hızlı sonuç alınabilir. Denemek gerekir.

Ya da excelin yerleşik sıralama işlemi denenebilir...

 

[Muhammet Okumuş]

Korhan Bey excelde sort komutu ile sıralamayı yapabiliyorum. Ben hem kendimi geliştirmek hem de makrolarin daha hızlı sonuç vermesini istediğim için soruyorum. Dosyalarimda dizileri kullanmaya başladıktan sonra inanılmaz hızlı sonuç verdiler. Benim attığım kodlardaki sıralama tek sütun için dogru sonuç veriyor. Ama daha fazla sütun için doğru sonuç vermiyor. En son hangi sütun siralanmış ise o sütun doğru sıralı oluyor.

 

[Korhan Ayhan]

Alternatif...

Excelin yerleşik sıralama işlemi..

Ofis 365 sürümünde sorunsuz çalıştırdım...

Option Explicit

Sub Sorting_Multiple_Column()
    Dim WS As Worksheet
    Dim My_Source_Range As Range
    Dim My_Sort_Range As Range
    Dim Sort_Column As Range
    Dim X As Integer
   
    Application.ScreenUpdating = False
   
    Set WS = Sheets("Sayfa1")
    Set My_Source_Range = WS.Range("D4:I11")
    Set My_Sort_Range = WS.Range("L4:Q11")
   
    My_Sort_Range.ClearContents
   
    My_Source_Range.Copy My_Sort_Range.Cells(1, 1)
   
    With WS.Sort
        .SortFields.Clear
         For X = 1 To My_Sort_Range.Columns.Count
             Set Sort_Column = My_Sort_Range.Columns(X)
             .SortFields.Add2 Key:=Sort_Column, _
             SortOn:=xlSortOnValues, _
             Order:=xlAscending, _
             DataOption:=xlSortNormal
         Next
        .SetRange My_Sort_Range
        .Header = xlGuess
        .Apply
    End With

    Set WS = Nothing
    Set My_Source_Range = Nothing
    Set My_Sort_Range = Nothing
   
    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır."
End Sub

 

[Korhan Ayhan]

Bu da ADODB örneği...

Hızlarını siz karşılaştırırsınız..

Option Explicit

Sub Sort_With_Multiple_Column_ADODB()
    Dim My_Connection As Object
    Dim My_Recordset As Object
    Dim My_Query As String
    Dim WS As Worksheet
    Dim My_Source_Range As Range
    Dim My_Sort_Range As Range
    Dim Sort_Column As String
    Dim X As Integer
    
    Set WS = Sheets("Sayfa1")
    Set My_Connection = CreateObject("AdoDb.Connection")
    Set My_Recordset = CreateObject("AdoDb.Recordset")
    
    Set My_Source_Range = WS.Range("D3:I11")
    Set My_Sort_Range = WS.Range("L3:Q11")
    
    My_Sort_Range.ClearContents
    
    My_Source_Range.Copy My_Sort_Range.Cells(1, 1)
    
    My_Connection.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=Yes"";"
    
    My_Connection.Open
    
    For X = 1 To My_Sort_Range.Columns.Count
        If X = 1 Then
            Sort_Column = My_Sort_Range.Cells(1, X).Value
        Else
            Sort_Column = Sort_Column & ", " & My_Sort_Range.Cells(1, X).Value
        End If
    Next
    
    My_Query = "Select * From [" & WS.Name & "$" & My_Sort_Range.Address(0, 0) & "] Order By " & Sort_Column
    
    My_Recordset.Open My_Query, My_Connection
    
    WS.Range("L4").CopyFromRecordset My_Recordset

    My_Recordset.Close
    My_Connection.Close
    
    Set My_Source_Range = Nothing
    Set My_Sort_Range = Nothing
    Set WS = Nothing
    Set My_Recordset = Nothing
    Set My_Connection = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır."
End Sub

 

[Korhan Ayhan]

2# nolu mesaj ekindeki dosyada tüm önerilerim toplu şekilde modüllerde bulunuyor.

 

[veyselemre]

Sub test()
    Dim i
    With Range("D3:I11")
        For i = 9 To 4 Step -1
            .Sort Cells(4, i), xlAscending, , , , , , xlYes
        Next i
    End With
End Sub
Sub test2()
    Dim data, i, ii, iii, tmp
    data = Range("D4:I11").Value

    ReDim Preserve data(1 To UBound(data), 1 To UBound(data, 2) + 1)
    For i = 1 To UBound(data)
        For ii = 1 To UBound(data, 2) - 1
            data(i, UBound(data, 2)) = data(i, UBound(data, 2)) & vbTab & data(i, ii)
        Next ii
    Next i

    For i = 1 To UBound(data) - 1
        For ii = i + 1 To UBound(data)
            If data(i, UBound(data, 2)) > data(ii, UBound(data, 2)) Then
                For iii = 1 To UBound(data, 2)
                    tmp = data(i, iii)
                    data(i, iii) = data(ii, iii)
                    data(ii, iii) = tmp
                Next iii
            End If
        Next ii
    Next i

    Range("L4").Resize(UBound(data), UBound(data, 2) - 1).Value = data
End Sub

 

[Zeki Gürsoy]

Merhaba Muhammet Bey;

Hali hazırda sayfa üzerindeki listeyi çok daha verimli bir şekilde sıralayabiliriz. Dizi olarak sıralamak istemenizin özel bir nedeni var mı?

Bellekte bile olsa, çoklu işlem (multi threading) kullanılmadığında çok da verimli olmayacaktır. Ayrıca internette VBA için bulabileceğiniz algoritmaların çoğu tek boyutlu dizi olarak örneklenmiş.

.

 

[Korhan Ayhan]

Merhaba Muhammet Bey;

Hali hazırda sayfa üzerindeki listeyi çok daha verimli bir şekilde sıralayabiliriz. Dizi olarak sıralamak istemenizin özel bir nedeni var mı?
....

Korhan Bey excelde sort komutu ile sıralamayı yapabiliyorum. Ben hem kendimi geliştirmek hem de makrolarin daha hızlı sonuç vermesini istediğim için soruyorum.
...

 

[Muhammet Okumuş]

Öncelikle cevaplarınız için teşekkür ederim. Bilgisayarın başına yeni geçebildim. Kodları deneyeceğim.

Merhaba Muhammet Bey;

Hali hazırda sayfa üzerindeki listeyi çok daha verimli bir şekilde sıralayabiliriz. Dizi olarak sıralamak istemenizin özel bir nedeni var mı?

Bellekte bile olsa, çoklu işlem (multi threading) kullanılmadığında çok da verimli olmayacaktır. Ayrıca internette VBA için bulabileceğiniz algoritmaların çoğu tek boyutlu dizi olarak örneklenmiş.

.

Özel bir nedeni yok. Diziler dosyamdaki çalışmaları hızlandırdı. Dizi mantığını bildiğim için dosyalarımda uyarlayabiliyorum. Dizilerden daha hızlı bir yöntem varsa onları kullanmak isterim. Daha önceleri excel sayfasında verileri sıralıyordum. Bu da dosyayı yavaşlatıyordu. Ben makro çalışması bitene kadar excel sayfasında işlem yaptırmak istemiyorum.
Veriler bazen 1000 satır - 40 sütun civarında olabiliyor. Öğrenmek adına soruyorum. Sizce yukarıdaki yöntemlerden hangisi daha uygun ? (1000 satır -40 sütun için)
"Ayrıca internette VBA için bulabileceğiniz algoritmaların çoğu tek boyutlu dizi olarak örneklenmiş." Araştırdım bulamadım doğrusu.

 

[Muhammet Okumuş]

Korhan Bey burda hata verdi.

 

[Muhammet Okumuş]

Satır sayısını 1100 çıkardığımda en hızlı sonucu Veysel Bey'in ilk kodu verdi.
Sub test()
Dim i
With Range("D3:I11")
For i = 9 To 4 Step -1
.Sort Cells(4, i), xlAscending, , , , , , xlYes
Next i
End With
End Sub

 

[Muhammet Okumuş]

Veri sayısı artınca bu yöntem yavaşlıyor.

Sub test2()
Dim data, i, ii, iii, tmp
data = Range("D4:I11").Value

ReDim Preserve data(1 To UBound(data), 1 To UBound(data, 2) + 1)
For i = 1 To UBound(data)
For ii = 1 To UBound(data, 2) - 1
data(i, UBound(data, 2)) = data(i, UBound(data, 2)) & vbTab & data(i, ii)
Next ii
Next i

For i = 1 To UBound(data) - 1
For ii = i + 1 To UBound(data)
If data(i, UBound(data, 2)) > data(ii, UBound(data, 2)) Then
For iii = 1 To UBound(data, 2)
tmp = data(i, iii)
data(i, iii) = data(ii, iii)
data(ii, iii) = tmp
Next iii
End If
Next ii
Next i

Range("L4").Resize(UBound(data), UBound(data, 2) - 1).Value = data
End Sub

 

[Muhammet Okumuş]

Verileri 10.000 satıra kadar uzattığımda bulduğum sonuçlar.

 

[Muhammet Okumuş]

Korhan Bey en hızlısı ilk yazdığınız sıralama.

 

[Muhammet Okumuş]

Arkadaşlar verdiğiniz cevaplar için çok teşekkür ederim. Dizilerin en hızlı yöntem olmadığını anlamış oldum. Hız olarak Korhan Bey'in, sadelik olarak Veysel Bey'in kodları kullanışlı.
Sağ olun var olun arkadaşlar.