Filtre listesinin ilk ögesi

[kadir78]

VBA'yı kullanarak otomatik filtre listesindeki ilk öğeyi seçmek için nasıl kod yazabilirim?

 

[YUSUF44]

Biraz dolambaçlı yoldan şöyle oluyor. Makro ilk önce tablonun A sütununu kopyalayıp, boş bir sayfa ekliyor ve yapıştırıyor. Sonra bu sayfada yinelenenleri kaldırıyor. Tekrar ilk sayfaya geçiyor ve A sütununu diğer sayfadaki ilk değere göre flitreliyor. Tablonun A:T aralığında ve 1. satırda başlıklar olduğu kabul edilmiştir :

Sub ilkfiltre()
    Set s1 = ActiveSheet
    son = Cells(Rows.Count, "A").End(3).Row
    Range("A1:A" & son).Copy
    Sheets.Add After:=ActiveSheet
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Set s2 = ActiveSheet
    ActiveSheet.Range("$A$1:$A$" & son).RemoveDuplicates Columns:=1, Header:=xlNo
    s1.Select
    ActiveSheet.Range("$A$1:$T$" & son).AutoFilter Field:=1, Criteria1:= _
        s2.[A2]
End Sub

 

[kadir78]

Yusuf bey kodlar için teşekkür ederim. Bana lazım olan filtre yapılan sutunda hucrenin kenarında aşağı ok işaretine tıklayınca filtre sekmesi açılıyor. Buradaki filtre kutucuklarını işaretleyecek veya işaretini kaldıracak kod lazım. Buradaki kutucuklardan bahsediyorum. Ben derdimi anlatamadım kusura bakmayın.

 

[kadir78]

Ben günlük işlem yaptığım için her güne ait fitre seçenekleri değişken oluyor. Bu değişkenlikten dolayı filtre kutucuklarını işaretleyecek kod lazım oldu. Ben tekrardan özür dilerim vaktinizi alıyorum kusura bakmayın lütfen.

 

[YUSUF44]

Bu konuyla ilgili yaptığım aramada benim yaptığıma benzer yöntemler kullanıldığını gördüm. Tek farkı ben listeye sıralama yaptırmadığımdan filtre listesindeki ilk değeri değil asıl listedeki ilk değeri aldırmışım. Yapılan yorum şu şekilde "Filtredeki veriler aslında asıl verilerin yinelenenleri kaldırılmış ve A'dan Z'ye sıralanmış bir halidir" bu özellik nedeniyle bu yöntem kullanılıyor. O sayfadan yararlanarak kodları aşağıdaki şekilde değiştirdim. Ayrıca kodun sonuna oluşan sayfanın silinmesini de ekledim, isterseniz iptal edebilirsiniz:

Sub ilkfiltre()
    Set s1 = ActiveSheet
    son = Cells(Rows.Count, "A").End(3).Row
    Range("A1:A" & son).Copy
    Sheets.Add After:=ActiveSheet
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Set s2 = ActiveSheet
    ActiveSheet.Range("$A$1:$A$" & son).RemoveDuplicates Columns:=1, Header:=xlNo
    ActiveSheet.Sort.SortFields.Add2 Key:=Range( _
        "A2:A" & son), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range("A1:A" & son)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    s1.Select
    ActiveSheet.Range("$A$1:$T$" & son).AutoFilter Field:=1, Criteria1:= _
        s2.[A2]
    Application.DisplayAlerts = False
        s2.Delete
    Application.DisplayAlerts = True
End Sub

Kaynak:

https://stackoverflow.com/questions/53836796/select-1st-item-in-autofilter-list

 

[kadir78]

Yusuf bey sağolun çok teşekkür ederim. Elinize emeğinize sağlık. İyi günler hayırlı bayramlar.

 

[Korhan Ayhan]

Alternatif;

ADO yöntemi uygulanmıştır.

A sütunundaki veriler için kurgulanmıştır.

Option Explicit

Sub Filtre_Ogeleri()
    Dim Baglanti As Object, Kayit_Seti As Object, Sorgu As String, Liste As Variant
    
    If WorksheetFunction.CountA(Range("A2:A" & Rows.Count)) = 0 Then
        MsgBox "Uygun veri bulunamadı!", vbExclamation
        Exit Sub
    End If
    
    Set Baglanti = CreateObject("Adodb.Connection")
    Set Kayit_Seti = CreateObject("Adodb.Recordset")
    
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
    
    Sorgu = "Select Distinct F1 From [Sayfa1$A2:A] Order By F1 Asc"
    
    Kayit_Seti.Open Sorgu, Baglanti, 1, 1
    
    If Kayit_Seti.RecordCount > 0 Then
        Liste = Kayit_Seti.GetRows
        MsgBox "Filtre listesinin 1. öğesi ; " & Liste(0, 0) & vbCr & "Filtre listesinin 3. öğesi ; " & Liste(0, 2)
    End If
    
    If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
    If Baglanti.State <> 0 Then Baglanti.Close
    
    Set Baglanti = Nothing
    Set Kayit_Seti = Nothing
End Sub

 

[Korhan Ayhan]

Bu da başka bir alternatif;

System.Collection.ArrayList nesnesi kullanılmıştır.

Option Explicit

Sub Filtre_Ogeleri()
    Dim Dizi As Object, Veri As Variant, Son As Long, X As Long
    
    Set Dizi = CreateObject("System.Collections.ArrayList")
    
    Son = Cells(Rows.Count, 1).End(3).Row
    If Son < 2 Then Son = 3
    
    Veri = Range("A2:A" & Son).Value
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            If Not Dizi.Contains(Veri(X, 1)) Then Dizi.Add Veri(X, 1)
        End If
    Next
   
    If Dizi.Count > 0 Then
        Dizi.Sort
        MsgBox "Filtre listesinin 1. öğesi ; " & Dizi.Item(0) & vbCr & "Filtre listesinin 3. öğesi ; " & Dizi.Item(2)
    Else
        MsgBox "Uygun veri bulunamadı!", vbExclamation
    End If

    Set Dizi = Nothing
End Sub

 

[kadir78]

Korhan hocam çok sağolun teşekkürler. İyi bayramlar.