Süzme

[1903emre34@gmail.com]

Merhabalar,

Form'a bastığımız zaman,8990001,8990002,8990003,8980004,8980005,89800006 sıralanıyor, benim istediğim ana hesapları ve küçükten büyüğe sıralanması (898,899) şeklinde kodlarda nasıl değişiklik yapabiliriz

 

[Zeki Gürsoy]

Aşağıdaki kodları yapıştırın. Sıralama "quick sort" algoritma.

[SIZE=2]Private Sub CommandButton1_Click()
    Selection.AutoFilter Field:=1, Criteria1:=ComboBox2 & ComboBox1
End Sub

Private Sub CommandButton2_Click()
    ActiveSheet.ShowAllData
End Sub

Private Sub UserForm_Initialize()
    Set dic = CreateObject("Scripting.Dictionary")
    
    For a = 2 To [a65536].End(3).Row
        If Not dic.Exists(CStr(Cells(a, "a"))) Then _
            dic.Add CStr(Cells(a, "a")), Cells(a, "a")
    Next
    
    arr = dic.Items
    
    Call QuickSortVariants(arr, LBound(arr), UBound(arr))
    
    ComboBox1.List = arr
    
    ComboBox2.AddItem "="
    ComboBox2.AddItem ">="
    ComboBox2.AddItem ">"
    ComboBox2.AddItem "<="
    ComboBox2.AddItem "<"
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
[/SIZE]

 

[1903emre34@gmail.com]

Teşekkürler, Zeki bey

küçükten büyüğe sıralama yapıyor, ana hesaplarının (898,899) şeklinde sıralanmasını nasıl yapabiliriz

 

[Zeki Gürsoy]

Ekli dosyayı inceleyin.

[SIZE=2]Private Sub CommandButton1_Click()
    Dim ar() As String
    
    Select Case ComboBox2
        Case "="
            For a = 2 To [a65536].End(3).Row
                If Left(Cells(a, "a"), 3) = ComboBox1 Then
                    s = s + 1
                    ReDim Preserve ar(1 To s)
                    ar(s) = Cells(a, "a")
                End If
            Next
        Case ">="
            For a = 2 To [a65536].End(3).Row
                If Left(Cells(a, "a"), 3) >= ComboBox1 Then
                    s = s + 1
                    ReDim Preserve ar(1 To s)
                    ar(s) = Cells(a, "a")
                End If
            Next
        Case ">"
             For a = 2 To [a65536].End(3).Row
                If Left(Cells(a, "a"), 3) > ComboBox1 Then
                    s = s + 1
                    ReDim Preserve ar(1 To s)
                    ar(s) = Cells(a, "a")
                End If
            Next
        Case "<="
            For a = 2 To [a65536].End(3).Row
                If Left(Cells(a, "a"), 3) <= ComboBox1 Then
                    s = s + 1
                    ReDim Preserve ar(1 To s)
                    ar(s) = Cells(a, "a")
                End If
            Next
        Case "<"
            For a = 2 To [a65536].End(3).Row
                If Left(Cells(a, "a"), 3) < ComboBox1 Then
                    s = s + 1
                    ReDim Preserve ar(1 To s)
                    ar(s) = Cells(a, "a")
                End If
            Next
    End Select
    
    ActiveSheet.Range("A1:A" & [a65536].End(3).Row).AutoFilter Field:=1, _
        Criteria1:=ar, Operator:=xlFilterValues
End Sub

Private Sub CommandButton2_Click()
    ActiveSheet.ShowAllData
End Sub

Private Sub UserForm_Initialize()
    Set dic = CreateObject("Scripting.Dictionary")
    
    For a = 2 To [a65536].End(3).Row
        If Not dic.Exists(CStr(Left(Cells(a, "a"), 3))) Then _
            dic.Add CStr(Left(Cells(a, "a"), 3)), Left(Cells(a, "a"), 3)
    Next
    
    arr = dic.Items
    
    Call QuickSortVariants(arr, LBound(arr), UBound(arr))
    
    ComboBox1.List = arr
    
    ComboBox2.AddItem "="
    ComboBox2.AddItem ">="
    ComboBox2.AddItem ">"
    ComboBox2.AddItem "<="
    ComboBox2.AddItem "<"
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[/SIZE]

 

[1903emre34@gmail.com]

898 seçip, sonra ">=" seçildikten sonra aşağıdaki kısım hata verdi

ActiveSheet.Range("A1:A" & [a65536].End(3).Row).AutoFilter Field:=1, _
Criteria1:=ar, Operator:=xlFilterValues

 

[Zeki Gürsoy]

Hata oluşmuyor. Tekrar deneyin.

 

[1903emre34@gmail.com]

Üstad, teşekkürler tamam oldu