Ado ile yapılmış hali ektedir.

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