Skip to main content

AccessTr.neT


Gelişmiş Filtre Uygulamak

Gelişmiş Filtre Uygulamak

#1
Gelişmiş süzgeç ile kritere göre aradığım bilgileri formülsüz bir şekilde süzmek istiyorum. Verilerim yıllık ve 5000 satır civarında oluyor. Acaba nasıl yapabilirim. Gelişmiş süzgeç mantığını macroya bağlayarak kriterleri girdikten sonra verilerim gelmiş olacak. Yardımcı olan arkadaşlara teşekkür ederim.
.rar İdari Yaptırım - 2020.rar (Dosya Boyutu: 68,2 KB | İndirme Sayısı: 9)
Cevapla
#2
Arkadaşlar gelişmiş filtre ile ilgili başka sayfada filtreleme işlemini bir türlü yapamadım acaba yardımcı olabilecek arkadaş var mı?
Cevapla
#3
Ado ile yapılmış hali ektedir.

[Resim: do.php?img=9985]

Sub listele()

    Dim s As String
    Dim con As Object
    Dim rs As Object
   
    say = 8
   
    With Sayfa2
        Application.ScreenUpdating = False
        .Range("D8:M" & Rows.Count).Clear
        Set con = CreateObject("adodb.connection")
        Set rs = CreateObject("adodb.recordset")
        con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1"""
       
            s = "select f1,f2,f3,f5,f6,f7,f8,f9,f10,f11 from [Veri$E4:P65536] where not isnull(f1)"
            If .Range("D7").Value <> "" Then s = s & " and f1 like '%" & .Range("D7").Value & "%'"
            If .Range("E7").Value <> "" Then s = s & " and f2 like '%" & .Range("E7").Value & "%'"
            If .Range("F7").Value <> "" Then s = s & " and f3 like '%" & .Range("F7").Value & "%'"
            If .Range("g7").Value <> "" Then s = s & " and f5 like '%" & .Range("g7").Value & "%'"
            If .Range("H7").Value <> "" Then s = s & " and f6 like '%" & .Range("H7").Value & "%'"
            If .Range("I7").Value <> "" Then s = s & " and f7 like '%" & .Range("I7").Value & "%'"
            If .Range("j7").Value <> "" Then s = s & " and f8 like '%" & .Range("j7").Value & "%'"
            If .Range("k7").Value <> "" Then s = s & " and f9 like '%" & .Range("k7").Value & "%'"
            If .Range("L7").Value <> "" Then s = s & " and f10 like '%" & .Range("L7").Value & "%'"
            If .Range("M7").Value <> "" Then s = s & " and f11 like '%" & .Range("M7").Value & "%'"
            On Error Resume Next
            rs.Open s, con, 1
                If rs.RecordCount > 0 Then
                Do While Not rs.EOF
                    .Cells(say, 4).Value = rs(0)
                    .Cells(say, 5).Value = rs(1)
                    .Cells(say, 6).Value = rs(2)
                    .Cells(say, 7).Value = Format(rs(3), "dd.mm.yyyy")
                    .Cells(say, 8).Value = rs(4)
                    .Cells(say, 9).Value = rs(5)
                    .Cells(say, 10).Value = rs(6)
                    .Cells(say, 11).Value = rs(7)
                    .Cells(say, 12).Value = rs(8)
                    .Cells(say, 13).Value = rs(9)
                    say = say + 1
                  rs.movenext
                Loop
            End If
        Application.ScreenUpdating = True
    End With
   
    rs.Close
    con.Close
    Set con = Nothing
    Set rs = Nothing
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect([D7:M7], Target) Is Nothing Then Call listele
End Sub
.rar İdari Yaptırım - 2020.rar (Dosya Boyutu: 77,19 KB | İndirme Sayısı: 4)
Cevapla
#4
Eğer avaş çalışırsa alttaki gibide yapabilirsiniz.


Private Sub Worksheet_Change(ByVal Target As Range) isterseniz eklediğim dosyadaki soldaki kodu silip Listele makrosunuda çalıştırabilirsiniz.Safa koduolduğu için yavaş olabilir.




Sub listele()

    Dim s As String
    Dim con As Object
    Dim rs As Object
    Dim arr
    say = 1
   
    With Sayfa2
        Application.ScreenUpdating = False
        .Range("D8:M" & Rows.Count).Clear
        Set con = CreateObject("adodb.connection")
        Set rs = CreateObject("adodb.recordset")
        con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1"""
       
            s = "select f1,f2,f3,f5,f6,f7,f8,f9,f10,f11 from [Veri$E4:P65536] where not isnull(f1)"
            If .Range("D7").Value <> "" Then s = s & " and f1 like '%" & .Range("D7").Value & "%'"
            If .Range("E7").Value <> "" Then s = s & " and f2 like '%" & .Range("E7").Value & "%'"
            If .Range("F7").Value <> "" Then s = s & " and f3 like '%" & .Range("F7").Value & "%'"
            If .Range("g7").Value <> "" Then s = s & " and f5 like '%" & .Range("g7").Value & "%'"
            If .Range("H7").Value <> "" Then s = s & " and f6 like '%" & .Range("H7").Value & "%'"
            If .Range("I7").Value <> "" Then s = s & " and f7 like '%" & .Range("I7").Value & "%'"
            If .Range("j7").Value <> "" Then s = s & " and f8 like '%" & .Range("j7").Value & "%'"
            If .Range("k7").Value <> "" Then s = s & " and f9 like '%" & .Range("k7").Value & "%'"
            If .Range("L7").Value <> "" Then s = s & " and f10 like '%" & .Range("L7").Value & "%'"
            If .Range("M7").Value <> "" Then s = s & " and f11 like '%" & .Range("M7").Value & "%'"
            On Error Resume Next
            rs.Open s, con, 1
                If rs.RecordCount > 0 Then
               
                ReDim arr(1 To rs.RecordCount, 1 To 10)
                Do While Not rs.EOF
                    arr(say, 1) = rs(0)
                    arr(say, 2) = rs(1)
                    arr(say, 3) = rs(2)
                    arr(say, 4) = Format(rs(3), "dd.mm.yyyy")
                    arr(say, 5) = rs(4)
                    arr(say, 6) = rs(5)
                    arr(say, 7) = rs(6)
                    arr(say, 8) = rs(7)
                    arr(say, 9) = rs(8)
                    arr(say, 10) = rs(9)
                    say = say + 1
                    rs.movenext
                Loop
                .Range("d8").Resize(say - 1, 10).Value = arr
            End If
        Application.ScreenUpdating = True
    End With
   
    rs.Close
    con.Close
    Set con = Nothing
    Set rs = Nothing
    Erase arr
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect([D7:M7], Target) Is Nothing Then Call listele
End Sub
Cevapla
#5
Yada sadece bu kodu Arama safasınının kod yerine yapıştırınz.

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
    With Sheets("Veri")
        If Not Intersect([D7:M7], Target) Is Nothing Then
            [D9:P1048576].Clear
            .Range("E3:P" & .Cells(Rows.Count, "D").End(3).Row).AdvancedFilter Action:=xlFilterCopy, _
                CriteriaRange:=Range("D6:O7"), CopyToRange:=Range("D9")
        End If
    End With
Application.ScreenUpdating = True
End Sub
Cevapla
#6
Sayın feraz emeğinize sağlık. Sayfa aramada sol tarafta bulunan form denetimi tiklerinden işaretlediğim zaman verileri getirmiyor. Acaba neden olabilir? Son kod da ilgili yerlere veriyi getirmiyor veri sayfasının başlıklarını falan getiriyor. Ayarlamaya çalıştım ama yapamadım. Acaba son kod a bir daha bakabilirmisiniz uygun zamanda. Teşekkür ederim.
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da
Task