Seçeneğe Göre Sıralama

[1Al2Ver]

Merhaba,

"SIRALI" isimli sayfaya 2 adet OptionButton ekledim,

1 nci OptionButton'un ismi ; "İlk 20",

2 nci OptionButton'un ismi ; "Hepsi",

Aşağıdaki kod, "SIRALI" isimli sayfada "U1" den seçim yapınca çalışıyor,

İsteğim; Mevcut kod'un, OptionButton'lara göre de bir seçim yapıp verileri getirmesidir,

Örneğin ; "İlk 20" düğmesi seçildiğinde kod, "U3:W23" aralığına, "Hepsi" düğmesi seçildiğinde ise "U3:W" aralığına veri almalı.

NOT ; Kullanıcı'nın, önce OptionButton'lardan, sonra da "U1" den seçim yapmak zorunda kalması gerektiğini düşünüyorum.

Teşekkür ederim.

Sub SIRALI_FİLTRE()

Set av = Sheets("AV_GENEL"): Set S = Sheets("SIRALI")
If S.[U1] = "" Or WorksheetFunction.CountIf(av.Range("1:1"), S.[U1]) = 0 Then Exit Sub
Son = Sheets("AV_GENEL").Cells(Rows.Count, 2).End(3).Row
sut = WorksheetFunction.Match(S.[U1], av.Range("1:1"), 0)
av.Range("A2:B" & Son).Copy S.[T4]
av.Range(av.Cells(1, sut), av.Cells(Son, sut)).Copy S.[W3]
S.Range("U3:W" & Son + 3).Sort S.[W3], xlDescending

End Sub

 

[1Al2Ver]

Merhaba,

Dosya ekledim,

Sayfa Kod'u ;

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, [U1]) Is Nothing Then
On Error GoTo çıkış

Set av = Sheets("AV_GENEL"): Set S = Sheets("SIRALI")
If S.[U1] = "" Or WorksheetFunction.CountIf(av.Range("1:1"), S.[U1]) = 0 Then Exit Sub
Son = Sheets("AV_GENEL").Cells(Rows.Count, 2).End(3).Row
sut = WorksheetFunction.Match(S.[U1], av.Range("1:1"), 0)
av.Range("A2:B" & Son).Copy S.[T4]
av.Range(av.Cells(1, sut), av.Cells(Son, sut)).Copy S.[W3]
S.Range("U3:W" & Son + 3).Sort S.[W3], xlDescending
End If
çıkış:
End Sub

Teşekkür ederim.

 

[veyselemre]

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, [U1]) Is Nothing Then
        On Error GoTo çıkış

        Set av = Sheets("AV_GENEL"): Set S = Sheets("SIRALI")
        If S.[U1] = "" Or WorksheetFunction.CountIf(av.Range("1:1"), S.[U1]) = 0 Then Exit Sub
        son = Sheets("AV_GENEL").Cells(Rows.Count, 2).End(3).Row
        If OptionButton1.Value = True Then son = 21
        
        sut = WorksheetFunction.Match(S.[U1], av.Range("1:1"), 0)
        S.Range("U3:W1000").ClearContents
        av.Range("A2:B" & son).Copy S.[T4]
        av.Range(av.Cells(1, sut), av.Cells(son, sut)).Copy S.[W3]
        
        S.Range("U3:W" & son + 3).Sort S.[W3], xlDescending
    End If
çıkış:
End Sub

 

[1Al2Ver]

Sayın veyselemre, merhaba,

İlginiz ve çözümünüz için teşekkür ederim, sağ olun.

Sanırım benim açıklamamda bir konuya değinmedim, o da şuydu,

İlk 20'den kasıt , "U1" den seçilene göre, en yüksek değerden başlayan ilk 20'nin sıralaması ("W4:W1000" aralığ)ı olmalıydı.

Mümkünse, kodu bu kritere göre düzenleyebilir misiniz ?

Teşekkür ederim.

 

[veyselemre]

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, [U1]) Is Nothing Then
        On Error GoTo çıkış

        Set av = Sheets("AV_GENEL"): Set S = Sheets("SIRALI")
        If S.[U1] = "" Or WorksheetFunction.CountIf(av.Range("1:1"), S.[U1]) = 0 Then Exit Sub
        son = Sheets("AV_GENEL").Cells(Rows.Count, 2).End(3).Row
        sut = WorksheetFunction.Match(S.[U1], av.Range("1:1"), 0)
        S.Range("T3:W1000").ClearContents
        av.Range("A2:B" & son).Copy S.[T4]
        av.Range(av.Cells(1, sut), av.Cells(son, sut)).Copy S.[W3]
       
        S.Range("U3:W" & son + 3).Sort S.[W3], xlDescending
        If OptionButton1.Value = True Then S.Range("T24:W1000").ClearContents
    End If
çıkış:
End Sub

 

[1Al2Ver]

Sayın veyselemre, merhaba,

Teşekkür ederim, elinize sağlık, sorunsuz çalışıyor,

Sağlıcakla kalın,

Saygılarımla.