Veri süz ve tarih sırasına göre başka sayfaya aktar

[m.gur]

Selam sayın forum üyeleri;
Tam olarak isteğim doğrultusunda bir örnek bulamadım. Sizlerden yardım talebinde bulunmak zorunda kaldım. Listemde 900 satırlık bilgi mevcut. Ben bu bilgileri bazı kriterlere göre süzüp çıktısını alıyorum. Ancak süzdüğüm bilgilerin bazı sütunları aktarılmayacak. Süzülen veriler artan tarih sırasına göre diğer sayfaya aktarılacak. EK te gönderdiğim örneğe uygun bir makroya ihtiyacım var. Şimdiden teşekkürler.

 

[Recep İpek]

Aşağıdaki kodları kendinize göre revize edebilirsiniz.

Sub BulAktar()
Set s1 = Sheets("GÖVDE")
Set s2 = Sheets("PARÇA")
Application.ScreenUpdating = False
s2.Range("a3:j100").ClearContents 'Silinecek Alana göre Düzeltiniz.
veri = InputBox("Aktarılacak Yıl Ömrünü Giriniz.", "UYARI", 5)
    For j = 4 To s1.[a65536].End(3).Row
        If Val(veri) = s1.Cells(j, "I").Value Then
        sat = s2.[a65536].End(3).Row + 1
        s2.Cells(sat, "a").Value = s1.Cells(j, "a").Value
        s2.Cells(sat, "b").Value = s1.Cells(j, "b").Value
        s2.Cells(sat, "c").Value = s1.Cells(j, "c").Value
        s2.Cells(sat, "d").Value = s1.Cells(j, "I").Value
        s2.Cells(sat, "e").Value = s1.Cells(j, "j").Value
        s2.Cells(sat, "f").Value = s1.Cells(j, "k").Value
        s2.Cells(sat, "g").Value = s1.Cells(j, "L").Value
        s2.Cells(sat, "h").Value = s1.Cells(j, "m").Value
        s2.Cells(sat, "I").Value = s1.Cells(j, "n").Value
        s2.Cells(sat, "j").Value = s1.Cells(j, "o").Value
        End If
    Next j
s2.Select
Range("a3:j100").Select
    Selection.Sort Key1:=Range("g3"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
Application.ScreenUpdating = True
Range("a1").Select
MsgBox "Bitti"
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[m.gur]

Sayın Ripek
İlginiz için teşekkür ederim. Sanırım yanlış anlaşıldı yada ben sorunumu tam anlatamadım. Listeyi ben Gövde sayfası L sütununa göre süzüyorum. Örneklersek; L sütunu => süz-->özel--> eşit yada küçüktür 31.12.2008 şeklinde süzdüm.Süzülmüş olan veriyi L sütunundaki Artan Tarih sırasına göre aktarmak istiyorum.

 

[Korhan Ayhan]

Selamlar,

Alternatif olarak aşağıdaki kodu denermisiniz.

Sub AKTAR()
    Application.ScreenUpdating = False
    Set SG = Sheets("GÖVDE")
    Set SP = Sheets("PARÇA")
    SP.Select
    SP.[A3:J65536].ClearContents
    If SG.[Q1] = 0 Then Exit Sub
    SATIR = 3
    For X = 4 To SG.[A65536].End(3).Row
    If SG.Cells(X, 1).EntireRow.Hidden = False Then
    SP.Cells(SATIR, 1) = SG.Cells(X, 1)
    SP.Cells(SATIR, 2) = SG.Cells(X, 2)
    SP.Cells(SATIR, 3) = SG.Cells(X, 3)
    SP.Cells(SATIR, 4) = SG.Cells(X, 9)
    SP.Cells(SATIR, 5) = SG.Cells(X, 10)
    SP.Cells(SATIR, 6) = SG.Cells(X, 11)
    SP.Cells(SATIR, 7) = SG.Cells(X, 12)
    SP.Cells(SATIR, 8) = SG.Cells(X, 13)
    SP.Cells(SATIR, 9) = SG.Cells(X, 14)
    SP.Cells(SATIR, 10) = SG.Cells(X, 15)
    SATIR = SATIR + 1
    End If: Next
    SP.[A3:J65536].Sort Key1:=SP.Range("G3"), Order1:=xlAscending
    [C3].Select
    Set SG = Nothing
    Set SP = Nothing
    Application.ScreenUpdating = True
    MsgBox "BİLGİLER AKTARILMIŞTIR.", vbInformation
End Sub

 

[m.gur]

Sayın cost_control denedim ama çalışmadı sadece silme işlemini yapıyor başka bişey yapmıyor. tekrar incelermisiniz kodları. İyi çalışmalar.

 

[m.gur]

Sayın cost_control biraz daha kurcaladım kodları bişey dikkatimi çekti Q1=0 then exit yazmışsınız bu satırdan dolayı çalışmıyor Q1'e herhangi bir değer yazdığım zaman makro çalıştı. Ama bir uyarı mesajı çıktı ve mesajda 400 yazıyor. Bunun anlamı nedir. Msgbox "Bilgiler aktarılmıştır" iletisi çıkmıyor. Bilgilerinize.

 

[Korhan Ayhan]

Selamlar,

Ekte örnek dosyanızda gerekli düzenlemeyi yaptım. İncelermisiniz.

 

[m.gur]

Sayın cost_control; dosya bu haliyle çalışıyor. Esas dosyama ekleyip deneyeceğim. Bir problem çıkacağını sanmıyorum. Sonucu tekrar yazarım. Çok teşekkür ediyorum. İyi çalışmalar.

 

[m.gur]

Asıl dosyama ilave ettim mükemmel. Elleriniz dert görmesin. Elinize emeğinize sağlık. İyi çalışmalar.