Abey buda yavaş olan ve anlaşılır olan.

Sub Aktar()



Dim son As Long, i As Long, say As Long

Dim syfVeri As Worksheet

Dim syfListe As Worksheet





Set syfVeri = ThisWorkbook.Worksheets("Veri")

Set syfListe = ThisWorkbook.Worksheets("Liste")



With syfListe.Range("A2:L" & Rows.Count)

    .ClearContents

    .Borders.LineStyle = xlNone

End With



say = 1

With syfVeri

    son = .Range("A" & Rows.Count).End(3).Row + 1



    For i = 2 To son

        If LCase(.Cells(i, "i")) = "devam eden" Then

            say = say + 1

            syfListe.Cells(say, 3).Value = .Cells(i, 1).Value 'esittirden sonrasi veri sayfasi öncesi ise Liste sayfasi

            syfListe.Cells(say, 4).Value = .Cells(i, 2).Value

            syfListe.Cells(say, 5).Value = .Cells(i, 3).Value

            syfListe.Cells(say, 6).Value = .Cells(i, 4).Value

            syfListe.Cells(say, 7).Value = .Cells(i, 5).Value

            syfListe.Cells(say, 8).Value = .Cells(i, 6).Value

            syfListe.Cells(say, 9).Value = .Cells(i, 7).Value

            syfListe.Cells(say, 10).Value = .Cells(i, 8).Value

            syfListe.Cells(say, 11).Value = .Cells(i, 9).Value

            syfListe.Cells(say, 12).Value = .Cells(i, 10).Value

        End If

    Next

End With



If say > 0 Then

    With syfListe

        With .Range("C2:L" & say)

            .Sort syfListe.Range("j2"), xlAscending, , , , , , xlNo

            .Borders.LineStyle = 1

            MsgBox "Bitti"

        End With

    End With

Else

    MsgBox "Hic veri aktarilmadi.", vbExclamation, "Dikkat"

End If



On Error Resume Next

Set syfVeri = Nothing

Set syfListe = Nothing

End Sub