Verileri Kritere Göre Başka Sayfaya Aktarmak

Tam anlaşılır yapınca eklerim kodu birazdan abey.

Yukardaki kodlarda oynama yapabilirsiniz sadece.Veri sayfasının son sütun nosunuda buluyor  çözgi ekliyor Liste sayfasına.
Birde klasik yavaş yöntemle eklerim tam anlarsınız.


Kodlar altta abey.

Sub Aktar()



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

Dim veri, devamedensutunNo As Byte

Dim syfVeri As Worksheet

Dim syfListe As Worksheet

Dim sonSutunNo_veri As Integer



Const gruplanacak_Sutun_Liste_Harf As String = "j"

Const devamEdenSutunHarf  As String = "i"



Set syfVeri = ThisWorkbook.Worksheets("Veri")

Set syfListe = ThisWorkbook.Worksheets("Liste")



With syfVeri

    sonSutunNo_veri = .Cells(1, Columns.Count).End(xlToLeft).Column

    

    For m = 1 To sonSutunNo_veri

        If LCase(Split(.Cells(1, m).Address, "$")(1)) = LCase(devamEdenSutunHarf) Then

            devamedensutunNo = m

            Exit For

        End If

    Next



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

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

    

    ReDim arr(1 To son, 1 To sonSutunNo_veri) 'UBound(veri, 2) demek verini son sütunu

    

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

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

            say = say + 1

            For k = 1 To sonSutunNo_veri

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

            Next

        End If

    Next

End With



    With syfListe

        With .Range(.Cells(2, 1), .Cells(Rows.Count, .Columns.Count))

            .Borders.LineStyle = xlNone

            .ClearContents

        End With

    End With



If say > 0 Then

    With syfListe.Range("C2").Resize(say, sonSutunNo_veri)

        .Value = arr

        .Sort syfListe.Cells(2, gruplanacak_Sutun_Liste_Harf), xlAscending, , , , , , xlNo

        .Borders.LineStyle = 1

    End With

End If



MsgBox "Bitti"

On Error Resume Next

Erase veri: Erase arr

Set syfVeri = Nothing

Set syfListe = Nothing

End Sub

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

teşekkürler sayın feraz bey alternatif üstüne alternatif emeğinize sağlık.