Gelişmiş Filtre Makrosu

[askm]

Kolay gelsin.
Gelişmiş filtre işlemini makro ile hızlı şekilde yapılabilir mi? Şöyle ki Makro kaydet ile gelişmiş filtre yapınca veri çok olunca yavaş oluyor.
Gelişmiş filtredeki gibi farklı sütunlara göre işlem yapmak istiyorum. Sayfa1 deki listeden öneğin Adı ali olanlar, İli İstanbul olanlar ve yaşı 30 olanları sayfa2 ye almak istiyorum. Normal for next döngüsü ile de uzun sürüyor. CreateObject("Scripting.Dictionary") ile yapılabilir mi?

 

[Korhan Ayhan]

Neden olmasın..

 

[askm]

Ekteki örnek için yardımcı olabilir misiz.

 

[Korhan Ayhan]

Dictionary ile ilgili forumda zaten birçok kodlama paylaşıldı. Araştırma yaptınız mı?

 

[askm]

İkili olarak sizin örnekleri gördüm ama 3 ve fazla kriter olunca yapamadım.

 

[Korhan Ayhan]

ADO ile ilgili kodlamayı deneyiniz.

Sayfa2 isimli sayfanızın kod bölümüne uygulayınız.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Baglanti As Object, Kayit_Seti As Object, Sorgu As String, Say As Byte, Veri As Range
    
    If Intersect(Target, Range("B3:B7")) Is Nothing Then Exit Sub
    
    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 * From [Sayfa1$A:E] Where "
    
    For Each Veri In Range("B3:B7")
        Say = Say + 1
        If Veri.Value <> "" Then
            If Say = 1 Then
                Sorgu = Sorgu & "F" & Say & " = '" & Veri.Value & "' "
            Else
                If Say = 3 Then
                    Sorgu = Sorgu & "And F" & Say & " = " & Veri.Value & " "
                Else
                    Sorgu = Sorgu & "And F" & Say & " = '" & Veri.Value & "' "
                End If
            End If
        End If
    Next
    
    With ActiveSheet
        .Range("D4:H" & .Rows.Count).ClearContents
        If Sorgu <> "Select * From [Sayfa1$A:E] Where " Then
            Kayit_Seti.Open Replace(Sorgu, "Where And", "Where"), Baglanti, 1, 1
            If Kayit_Seti.RecordCount > 0 Then
                .Range("D4").CopyFromRecordset Kayit_Seti
            End If
        End If
        .Columns.AutoFit
    End With
   
    If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
    If Baglanti.State <> 0 Then Baglanti.Close

    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
End Sub

 

[askm]

Çok teşekkür ederim. Elinize sağlık.