Argüman alabilen Autofilter Fonksiyonu

[acisos]

Merhaba arkadaşlar,
Uzun bir listeden belirli kriterlere göre filtre yapıyorum, filtre kriterleri sürekli değişiyor. 40 tane kriterim var dersek, uzun uzun statik şekilde 40 kriteri içeren macro yazmak yerine, hem göze daha güzel görünecek, hem de istediğim zaman daha kolay değiştirme yapabileceğim bir fonksiyon yazmaya çalışıyorum.

Kod olarak açıklamak gerekirse, ilk önce uzun yolu veriyorum, sonra da yapmak istediğimi...
1. filtre kriterleri

ActiveSheet.Range("$A$1:$O$596").AutoFilter Field:=13, Criteria1:="A"
    ActiveSheet.Range("$A$1:$O$596").AutoFilter Field:=6, Criteria1:="FULL" 
    ActiveSheet.Range("$A$1:$O$596").AutoFilter Field:=5, Criteria1:="-"
    ActiveSheet.Range("$A$1:$O$596").AutoFilter Field:=3, Criteria1:="20lik"

2. filtre kriterleri

ActiveSheet.Range("$A$1:$O$596").AutoFilter Field:=13, Criteria1:="A" 
    ActiveSheet.Range("$A$1:$O$596").AutoFilter Field:=6, Criteria1:="FULL"
    ActiveSheet.Range("$A$1:$O$596").AutoFilter Field:=5, Criteria1:="-"
    ActiveSheet.Range("$A$1:$O$596").AutoFilter Field:=3, Criteria1:=Array( _
        "20lik", "40lik", "60lik"), Operator:=xlFilterValues

Yapmak istediğim

Sub Filtre(ByVal KOLON As String, ByVal ARANAN As String)
     Dim rng As Range, res As Variant
Set rng = Sheets("SAYFA1").AutoFilter.Range.Rows(1) 
res = Application.Match(KOLON, rng, 0)
If Not IsError(res) Then
  rng.AutoFilter Field:=res, Criteria1:=Array( _
        ARANAN), Operator:=xlFilterValues
Else
  MsgBox "Header1 was not found"
End If
    
End Sub

Sub dene()
Filtre KOLON:="Tür", ARANAN:="A"
Filtre KOLON:="Durum", ARANAN:="FULL"
Filtre KOLON:="Ekstra", ARANAN:="-"
Filtre KOLON:="Tip", ARANAN:="20lik"
End Sub

Gördüğünüz gibi 2. filtre kriterlerinde array var, ilk önce bu bana problem çıkarıyor. İkinci problemimse bir kere filtre yaptıktan sonra, filtreyi resetlemek gerekli.. Tam açıklayamadıysam kusura bakmayın, kısacası argüman alan autofilter yapmak istiyorum.

 

[mancubus]

Array için şöyle bir şey deneyebilirsiniz...

Dim arananlar As String
arananlar = "Ahmet, Mehmet, Veli, Ayşe"
aranan = Split(arananlar, ", ")

 

[acisos]

Sub Filter(ByVal KOLON As String, ByVal ARANAN As String)
Dim rng As Range, res As Variant
    ' sayfa1 i degisken yap sonra
Set rng = Sheets("SAYFA1").AutoFilter.Range.Rows(1) 

res = Application.Match(KOLON, rng, 0)
If Not IsError(res) Then
Dim avarSplit As Variant
    avarSplit = Split(ARANAN, ",")
    If UBound(avarSplit) = 0 Then
  rng.AutoFilter Field:=res, Criteria1:=Array( _
        ARANAN), Operator:=xlFilterValues
        ElseIf UBound(avarSplit) = 1 Then
        rng.AutoFilter Field:=res, Criteria1:=Array( _
        avarSplit(0), avarSplit(1)), Operator:=xlFilterValues
           ElseIf UBound(avarSplit) = 2 Then
        rng.AutoFilter Field:=res, Criteria1:=Array( _
        avarSplit(0), avarSplit(1), avarSplit(2)), Operator:=xlFilterValues
             ElseIf UBound(avarSplit) = 3 Then
        rng.AutoFilter Field:=res, Criteria1:=Array( _
        avarSplit(0), avarSplit(1), avarSplit(2), avarSplit(3)), Operator:=xlFilterValues
             ElseIf UBound(avarSplit) = 4 Then
        rng.AutoFilter Field:=res, Criteria1:=Array( _
        avarSplit(0), avarSplit(1), avarSplit(2), avarSplit(3), avarSplit(4)), Operator:=xlFilterValues
        End If
        
Else
  MsgBox KOLON & " was not found"
End If

Sub ara40lik()
Call Filter("Tür", "A")
Call Filter("Durum", "FULL")
Call Filter("Ekstra", "-")
Call Filter("Tip", "20lik, 40lik")
End Sub

Böyle çözdüm.

Şimdiyse filtreden çıkan sonuçların sadece görünenlerini bir array içerisine almaya çalışıyorum.
http://support.microsoft.com/kb/213798
bu sayfada verilmiş nasıl yapılacağı ama görünen hücrelerin rangeini nasıl vereceğim bilemedim.

Dim myarray As Variant
myarray = Range("a1:a10").Value

Misal myarray karşısına filtreden çıkan sonuçların sadece görünenlerinin rangeini yazmam gerekiyor.
Excelde ve vba da yeniyim, daha önce başka programlama dillerinde birşeyler geliştiriyordum, araştıra araştıra öğrenmeye çalışıyorum, yardımlar için teşekkürler.

 

[Korhan Ayhan]

Merhaba,

Gizlenen satırları döngüye alın ve redim komutuyla diziye yükleyin.

Ya da F5-ÖZEL menüsünden yalnızca görünen hücreler seçeneğini kullanarak diziye almayı deneyin.