Option Compare Text



Private Sub Worksheet_Change(ByVal Target As Range)

Application.ScreenUpdating = False

    With Sheets("Veri")

        If Not Intersect([D7:M7], Target) Is Nothing Then

          listele

        End If

    End With

Application.ScreenUpdating = True

End Sub

Sub listele()

    

        Dim veri, sonVeri As Integer, key1, key2, say As Integer, i As Integer

        

        With Sayfa1

            sonVeri = .Cells(Rows.Count, "D").End(3).Row + 1

            veri = .Range("E4:P" & sonVeri).Value

        End With

        

        ReDim arr(1 To 12, 1 To UBound(veri, 1)) '12 arama saydasi D ile P arasi sütun sayisi

        

        With Sayfa2

            If WorksheetFunction.CountA(.Range("D7:M7")) = 0 Then

                .Range("D8:M" & Rows.Count).ClearContents

                GoTo son

            End If

            

            key1 = "*" & .Range("D7").Value & "*|*" & .Range("E7").Value & "*|*" & .Range("F7").Value & "*|*" & .Range("G7").Value & "*|*" & _

                        .Range("H7").Value & "*|*" & .Range("I7").Value & "*|*" & .Range("J7").Value & "*|*" & _

                        .Range("K7").Value & "*|*" & .Range("L7").Value & "*|*" & .Range("M7").Value & "*"

        End With

        

        For i = LBound(veri) To UBound(veri)

            key2 = "*" & veri(i, 1) & "*|*" & veri(i, 2) & "*|*" & veri(i, 3) & "*|*" & veri(i, 5) & _

                                      "*|*" & veri(i, 6) & "*|*" & veri(i, 7) & "*|*" & veri(i, 8) & _

                                      "*|*" & veri(i, 9) & "*|*" & veri(i, 10) & "*|*" & veri(i, 11) & "*"

            If CStr(key2) Like CStr(key1) Then

                say = say + 1

                arr(1, say) = veri(i, 1)

                arr(2, say) = veri(i, 2)

                arr(3, say) = veri(i, 3)

                arr(4, say) = veri(i, 5)

                arr(5, say) = veri(i, 6)

                arr(6, say) = veri(i, 7)

                arr(7, say) = veri(i, 8)

                arr(8, say) = veri(i, 9)

                arr(9, say) = veri(i, 10)

                arr(10, say) = veri(i, 11)

            End If

        Next

        

        With Sayfa2 '******

            .Range("D8:M" & Rows.Count).ClearContents

            If say > 0 Then

                ReDim Preserve arr(1 To UBound(arr), 1 To say)

                .Range("D8").Resize(say, 10).Value = Application.Transpose(arr)

            End If

        End With '******

son:

        On Error Resume Next

        

        Application.ScreenUpdating = True

        

        Erase arr: key1 = vbNullString: key2 = vbNullString: Erase veri

End Sub