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