Dizilerle veri alma & Sıralama

[Muhammet Okumuş]

Arkadaşlar merhaba.
Dosyamda öğrenci notlarını değerlendiriyorum. Dosya her geçen gün veri olarak artıyor. Filtreleme yöntemi ile verileri alabiliyorum. Ama ben dosyamda dizileri kullanmak ve dizileri öğrenmek istiyorum. Dosyamda veri çekme ve sıralama işlemlerinin tamamen diziler ile yapmak istiyorum.

 

[vardar07]

Dosyayı inceler misiniz. Dizi makro pek bilmem ama sanırım işinizi görür.

 

[Muhammet Okumuş]

Sn vardar07, cevabınız için teşekkür ederim. Ama ben sonuca dizilerle gitmek istiyorum. Dizileri öğrenmek istiyorum. Filtreleme yöntemi ile sonuca gidebiliyorum. Ama diziler döngülere göre çok daha hızlı.

 

[Vedat Özer]

Merhabalar,

Alternatif olarak aşağıdaki kodları kullanabilirsiniz.

Sub Test1()
    Dim S1 As Worksheet, S2 As Worksheet, X As Long, Son As Long, Say As Long, Liste(), Veri(), Zaman As Double
    Dim Hesap As String
    Zaman = Timer
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    Set S1 = Sheets("Veri")
    Set S2 = Sheets("İzle")
    
    S2.Range("g8:o" & S2.Rows.Count).ClearContents
    
    Son = S1.Cells(S1.Rows.Count, 5).End(3).Row
    Say = 1
    
    Liste = S1.Range("B3:K" & Son).Value
    ReDim Veri(1 To Son, 1 To 9)

    Hesap = S2.Range("H3").Value
  

    For X = LBound(Liste) To UBound(Liste)
                    If Liste(X, 5) = Hesap Then
                 
                    ReDim Preserve Veri(1 To Son, 1 To 9)
                    Veri(Say, 1) = Liste(X, 2)
                    Veri(Say, 2) = Liste(X, 4)
                    Veri(Say, 5) = Liste(X, 6)
                    Veri(Say, 7) = Liste(X, 8)
                    Veri(Say, 8) = Liste(X, 9)
                    Veri(Say, 9) = Liste(X, 10)
                    Say = Say + 1
                
            End If
        
    Next

    If Say > 0 Then
        S2.Range("g8").Resize(Say, 9) = Veri
       
    End If
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With

    MsgBox "Listelendi. " & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    
End Sub

 

[Muhammet Okumuş]

Vedat Bey cevabınız için teşekkür ederim. Rica etsem sıralama ile ilgili bir şeyler yapabilir miyiz? Yazmış olduğunuz kodları inceleyeceğim.

 

[Erdem Akdemir]

Muhammet bey merhaba,

Sıralamayı neye göre yaptırmak istiyorsunuz.

 

[Muhammet Okumuş]

Ortalama puanlara göre.

 

[vardar07]

Nolu mesajdaki dosyada bulunan sırala (makro kaydet ile) işinizi görmezmi?

 

[Muhammet Okumuş]

Hocam kodlar ile sıralama yapabiliyorum. Ama dizilerle yapmak istiyorum.

 

[Erdem Akdemir]

Muhammet bey merhaba,

Dizinlere alternatif olarak hazırladığım örneği inceleyebilirsiniz.
Dizinlere göre daha kısa ve öğrenmesi daha kolaydır.

 

[Muhammet Okumuş]

Sn kuvari dosyanız her hangi bir işlem yapmıyor.

 

[Zeki Gürsoy]

Merhaba;

Sıralama algoritmalarından olan "Quick Sort" algoritmasına ait arşivlediğim bir örneği (kodu) ekliyorum. Umarım faydası olur.

Not: Örnek tek boyutlu diziler içindir. İki boyutlu diziler için algoritmada değişiklik gerekir.

Sub test()
    Dim arr(50000)
    Dim t1 As Single, t2 As Single
    Dim z As Long
    
    Randomize
    
    For z = 0 To 50000
        arr(z) = Fix(Rnd * 100000 + 1)
    Next
    
   [COLOR=DarkGreen] 'arr = Array("Ç", 6, 7, "g", 71, "q", "armut", 9, "ç", "Ali", "abi", "7ab")
    'Stop[/COLOR]
    
    t1 = Timer
    
    Call QuickSortVariants(arr, LBound(arr), UBound(arr))
    
    t2 = Timer
    
    Range("a1:a" & UBound(arr) + 1) = Application.WorksheetFunction.Transpose(arr)
    
    Erase arr
    
    MsgBox t2 - t1
End Sub

Public Sub QuickSortVariants(vArray, inLow As Long, inHi As Long)
'' orjinal
    Dim pivot   As Variant
    Dim tmpSwap As Variant
    Dim tmpLow  As Long
    Dim tmpHi   As Long
    
    tmpLow = inLow
    tmpHi = inHi
    
    pivot = vArray((inLow + inHi) \ 2)
    
    Do While (tmpLow <= tmpHi)
    
        While (vArray(tmpLow) < pivot And tmpLow < inHi)
            tmpLow = tmpLow + 1
        Wend
        
        While (pivot < vArray(tmpHi) And tmpHi > inLow)
            tmpHi = tmpHi - 1
        Wend
        
        If (tmpLow <= tmpHi) Then
            tmpSwap = vArray(tmpLow)
            vArray(tmpLow) = vArray(tmpHi)
            vArray(tmpHi) = tmpSwap
            tmpLow = tmpLow + 1
            tmpHi = tmpHi - 1
        End If
    
    Loop
    
    If (inLow < tmpHi) Then QuickSortVariants vArray, inLow, tmpHi
    If (tmpLow < inHi) Then QuickSortVariants vArray, tmpLow, inHi
End Sub

 

[Muhammet Okumuş]

Zeki Bey, dosyada her hangi bir sıralama yapmadı. Msgbox ile zaman ölçüyor sadece.

Zaman aralığı 0,50 civarında.

Ben Vedat Bey'in kodlarında deneme yanılma yoluyla yaptım. Zaman 0.30 civarı.

Sub Test2_Sırala()
Dim S1 As Worksheet, S2 As Worksheet, x As Long, Son As Long, Say As Long, Liste(), Sıralı(), Veri(), t As Double
Dim Hesap As String
t = Timer



Set v = Sheets("Veri")


Range("G8:O100,U3:Z42").ClearContents

Son = v.Cells(Rows.Count, 5).End(3).Row
Say = 1
q = 1

Liste = v.Range("B3:K" & Son).Value
ReDim Veri(1 To Son, 1 To 9)

alt = Cells(Rows.Count, 5).End(3).Row
ReDim Sıralı(1 To alt - 2, 1 To 6)

For ii = 3 To alt
xxx = 0
yyy = 0
zzz = 0
aaa = 0
num = Cells(ii, 4)


For x = LBound(Liste) To UBound(Liste)
If Liste(x, 4) = num And Liste(x, 1) = Range("D2") Then




ReDim Preserve Veri(1 To Son, 1 To 9)
Veri(Say, 1) = Liste(x, 2)
Veri(Say, 2) = Liste(x, 3)
Veri(Say, 5) = Liste(x, 6)
Veri(Say, 7) = Liste(x, 8)
Veri(Say, 8) = Liste(x, 9)
Veri(Say, 9) = Liste(x, 10)
xxx = xxx + Veri(Say, 7)
yyy = yyy + Veri(Say, 8)
zzz = zzz + Veri(Say, 9)
If (xxx + yyy + zzz) = 0 Then GoTo 1
aaa = xxx * 100 / (xxx + yyy + zzz)
1
Say = Say + 1

End If

Next

If Say > 0 Then
ReDim Preserve Sıralı(1 To alt - 2, 1 To 6)

Sıralı(q, 1) = Cells(ii, 5)
If (xxx + yyy + zzz) = 0 Then GoTo 101
Sıralı(q, 2) = aaa
Sıralı(q, 4) = xxx
Sıralı(q, 5) = yyy
Sıralı(q, 6) = zzz
101
q = q + 1
End If
Next
Range("U3").Resize(q - 1, 6) = Sıralı
Range("U3:Z42").Sort Range("V3"), 2
MsgBox Format(Timer - t, "0.00")
End Sub

 

[Ziynettin]

Merhaba,
Kodları module ve sıralama düğmesine atayıp deneyiniz.

Sub Sirala_Test()
Dim b()
    Set S2 = Sheets("İzle")
    Son = S2.Cells(Rows.Count, "G").End(3).Row
    If Son < 8 Then Son = 8
    b = S2.Range("G8:O" & Son).Value
    Call Sirala(b(), 5, LBound(b, 1), UBound(b, 1))
    S2.[G8].Resize(UBound(b, 1), UBound(b, 2)).Value2 = b
End Sub
Sub Sirala(a(), Sutun, Sat1, Sat2)
    r = a((Sat1 + Sat2) \ 2, Sutun)
    X = Sat1: y = Sat2
    Do: Do While a(X, Sutun) < r: X = X + 1: Loop
        Do While r < a(y, Sutun): y = y - 1: Loop
        If X <= y Then
            For k = LBound(a, 2) To UBound(a, 2)
                i = a(X, k)
                a(X, k) = a(y, k)
                a(y, k) = i
            Next k
            X = X + 1
            y = y - 1
        End If
    Loop While X <= y
    If X < Sat2 Then Call Sirala(a, Sutun, X, Sat2)
    If Sat1 < y Then Call Sirala(a, Sutun, Sat1, y)
End Sub

 

[Muhammet Okumuş]

İşlem yapmadı.

 

[Ziynettin]

#14# nolu mesajda dosya eklendi denermisiniz.

 

[Muhammet Okumuş]

Hocam ben öğrencin aldığı notları değil. U:Z aralığında sınıf başarı durumunu sıralamak istiyorum.