Filtre uygulunan sütunlar bulma?

[hsayar]

şöyleki
sayfada a5:f5 sütun aralığında, filtre uygula aktif c ve d sütunlarında veri süzme işlemi onaylanmış

filte uygulanan hücreleri diziye nasıl alırız. örneğimize gör sonuc c5,d5 olacak

 

[Levent Menteşoğlu]

Aşağıdaki kodları deneyin.

Dim suz
 
Sub suzmelistesi()
ReDim suz(ActiveSheet.AutoFilter.Filters.Count)
For a = 1 To ActiveSheet.AutoFilter.Filters.Count
If ActiveSheet.AutoFilter.Filters.Item(a).On Then
c = c + 1
suz(c) = ActiveSheet.AutoFilter.Range.Cells(a).Address(0, 0)
MsgBox suz(c)
End If
Next
End Sub

 

[hsayar]

teşekkür ederim hocam bununla istediğim gibi filtre uygulanan adresler a1, c1 gibi dönüyor .

peki şöyle bir şey yapılabilirmi:
filte uygulanan adresler a1, c1 vs.

baslık = [a2].value & " & " [c2].value & [.....].value gibi bir değişkene
alınabilirmi.

baslik = baslik & Kriterler(Cells(filtre uygulanan sütun, filtre uygulanan satır + 1)) gibi birşey


Function Kriterler(BaslikAlti As Range) As String
Dim Filter As String
Filter = ""
On Error GoTo son
With BaslikAlti.Parent.AutoFilter
If Intersect(BaslikAlti, .Range) Is Nothing Then GoTo son
With .Filters(BaslikAlti.Column - .Range.Column + 1)
If Not .On Then GoTo son
Filter = Replace(.Criteria1, "=", """", 2)
Filter2 = Replace(.Criteria2, "=", """", 2)

Select Case .Operator
Case xlAnd
Filter = Filter & " ve " & Filter2
Case xlOr
Filter = Filter & " veya " & Filter2
End Select

End With
End With
son:
Kriterler = Filter
End Function

 

[mertdalagan]

E1 Yerine E1 Hücresinde yazılı değeri yazdırabilir miyiz.
teşekkürler.

 

[hsayar]

Dim suz
 
Sub suzmelistesi()
ReDim suz(ActiveSheet.AutoFilter.Filters.Count)
For a = 1 To ActiveSheet.AutoFilter.Filters.Count
If ActiveSheet.AutoFilter.Filters.Item(a).On Then
c = c + 1
suz(c) = ActiveSheet.AutoFilter.Range.Cells(a).Value
MsgBox suz(c)
End If
Next
End Sub

yazıca filtre uygulanan başlığı bulmak mümkün.....


Yalnız benim istediğim kriterler(filtre edilen sütun, filtre edilen satır + 1 ) şeklinde kullanmak

 

[Levent Menteşoğlu]

.....yazıca filtre uygulanan başlığı bulmak mümkün.....

Yalnız benim istediğim kriterler(filtre edilen sütun, filtre edilen satır + 1 ) şeklinde kullanmak

Bu istediğiniz verileri kolayca bulabileceğinizi düşünüyorum. Döngüdeki "a" değişkeni zaten sütun nosunu veriyor. Filtre edilmiş satır sayısını bulmak içinde en pratik yok Excelin kendi fonksiyonlarının VBA daki karşılığını kullanmaktır. Bu fonksiyonda ALTTOPLAM yani SUBTOTAL fonksiyonudur.

WorksheetFunction.Subtotal(102, [a:a])

 

[hsayar]

hocam yanlış anlattım şöyle bir örenk le açıklayayım

dönen adres a1 ise ben a2 yani (sütun, satır+1) değerini başka bir fonksiyonda kullanmak istiyorum.

 

[hsayar]

Dim suz
 
Sub suzmelistesi_adr()
'Süzülen adresleri verir a1, a2 ,a3 gibi
ReDim suz(ActiveSheet.AutoFilter.Filters.Count)
For a = 1 To ActiveSheet.AutoFilter.Filters.Count
If ActiveSheet.AutoFilter.Filters.Item(a).On Then
c = c + 1
suz(c) = ActiveSheet.AutoFilter.Range.Cells(a).Address(0, 0)
MsgBox suz(c)
End If
Next
End Sub

Sub suzmelistesi_SuzBas()
'Süzülen adreslerin başlıklarını verir adı, soyadı gibi

ReDim suz(ActiveSheet.AutoFilter.Filters.Count)
For a = 1 To ActiveSheet.AutoFilter.Filters.Count
If ActiveSheet.AutoFilter.Filters.Item(a).On Then
c = c + 1
suz(c) = ActiveSheet.AutoFilter.Range.Cells(a).Value
MsgBox suz(c)
End If
Next
End Sub

Sub suzmelistesi_SuzDeg()
'Süzülen adreslerin kritelerini verir ahmet, şenocak gb
ReDim suz(ActiveSheet.AutoFilter.Filters.Count)

For a = ActiveSheet.AutoFilter.Filters.Count To 1 Step -1
    If ActiveSheet.AutoFilter.Filters.Item(a).On Then
        c = c + 1
        stnno = ActiveSheet.AutoFilter.Range.Cells(a).Column
        strno = ActiveSheet.AutoFilter.Range.Cells(a).Row
        suz(c) = Kriterler(Cells(strno + 1, stnno))
        snc = suz(c) & ", " & snc
    End If
Next
MsgBox snc
End Sub


Function Kriterler(BaslikAlti As Range) As String
Dim Filter As String
Filter = ""
On Error GoTo son
With BaslikAlti.Parent.AutoFilter
If Intersect(BaslikAlti, .Range) Is Nothing Then GoTo son
With .Filters(BaslikAlti.Column - .Range.Column + 1)
If Not .On Then GoTo son
Filter = Replace(.Criteria1, "=", """", 2)
Filter2 = Replace(.Criteria2, "=", """", 2)

Select Case .Operator
Case xlAnd
Filter = Filter & " ve " & Filter2
Case xlOr
Filter = Filter & " veya " & Filter2
End Select

End With
End With
son:
Kriterler = Filter
End Function

evet hallettim gibi

 

[hsayar]

Tam olarak istediğimde buydu Şükürler oslun hallettim
Dim Suz 'varsa kullanmayın

Sub suzmelistesi_SuzKrm()
'Süzülen adreslerin kritelerini verir ahmet, şenocak gb
ReDim suz(ActiveSheet.AutoFilter.Filters.Count)

For a = ActiveSheet.AutoFilter.Filters.Count To 1 Step -1
    If ActiveSheet.AutoFilter.Filters.Item(a).On Then
        c = c + 1
        stnno = ActiveSheet.AutoFilter.Range.Cells(a).Column
        strno = ActiveSheet.AutoFilter.Range.Cells(a).Row
        SuzBas = ActiveSheet.AutoFilter.Range.Cells(a).Value
        SuzKrt = Kriterler(Cells(strno + 1, stnno))
        suz(c) = SuzBas & ": " & SuzKrt
        snc = suz(c) & ", " & snc
    End If
Next
MsgBox snc
End Sub

 

[hsayar]

yanlış başlığa yazmışım.