Abey önceki kodda aktarıyordu.
Alttaki kodu deneyin birde.
burdaki 10 yazanı 11 yaparsanız K sütununa kadar olur örneğin.

Sub Aktar()



Dim son As Long, i As Long, say As Long, k As Byte

Dim veri

Dim syfVeri As Worksheet

Dim syfListe As Worksheet



Const sonSutun As Byte = 10 'J sütun



Set syfVeri = ThisWorkbook.Worksheets("Veri")

Set syfListe = ThisWorkbook.Worksheets("Liste")



With syfVeri

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

    veri = .Range("A2", .Cells(son, sonSutun)).Value

    

    ReDim arr(1 To son, 1 To sonSutun)

    

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

        If LCase(veri(i, 9)) = "devam eden" Then

          say = say + 1

            For k = 1 To sonSutun

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

            Next

        End If

    Next

End With



syfListe.Range("C2:L" & Rows.Count).ClearContents



If say > 0 Then

    syfListe.Range("C2").Resize(say, sonSutun).Value = arr

    syfListe.Range("C2").Resize(say, sonSutun).Sort syfListe.Cells(2, sonSutun), xlAscending, , , , , , xlNo

End If



MsgBox "Bitti"

On Error Resume Next

Erase veri: Erase arr

Set syfVeri = Nothing

Set syfListe = Nothing

End Sub