Verileri şarta göre aktarma

[mserler]

A2 ile a221 arasındaki dolu hücreleri
"b" ve "d" hücrelerine göre sayfalara aktarmam gerekiyor.
Sitede bulup kendime göre uyarlamaya çalıştığım
makro ile dolu hücreleri teker teker sonuç sayfasına gönderebiliyorum
ama makroyu istediğim şekle göre uyarlayamadım .yardımınız için şimdiden teşekkürler

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, S4 As Worksheet, S5 As Worksheet
    Dim Satır1 As Long, Satır2 As Long, Satır3 As Long, Satır4 As Long
    Dim Hücre As Range
    Set S1 = Sheets("VERİ GİRİŞİ")
    Set S2 = Sheets("İNG ÇİM")
    Set S3 = Sheets("İNG KUM")
    Set S4 = Sheets("ARP ÇİM")
    Set S5 = Sheets("ARP KUM")
    
    Satır1 = 2: Satır2 = 2: Satır3 = 2: Satır4 = 2
    
    S2.[A2:S65536].ClearContents
    S3.[A2:S65536].ClearContents
    S4.[A2:S65536].ClearContents
    S5.[A2:S65536].ClearContents
    
    For Each Hücre In S1.Range("A2:A" & S1.[A65536].End(3).Row)
    If Hücre.Value <> "" Then
    If Hücre.Offset(0, 1).Value = "İNG" And Hücre.Offset(0, 5).Value = "Çim" Then
    S2.Range("A" & Satır1, "S" & Satır1).Value = S1.Range("A" & Hücre.Row, "S" & Hücre.Row).Value
    Satır1 = Satır1 + 1
    ElseIf Hücre.Offset(0, 1).Value = "İNG" And Hücre.Offset(0, 5).Value = "Kum" Then
    S3.Range("A" & Satır2, "S" & Satır2).Value = S1.Range("A" & Hücre.Row, "S" & Hücre.Row).Value
    Satır2 = Satır2 + 1
    ElseIf Hücre.Offset(0, 1).Value = "ARP" And Hücre.Offset(0, 5).Value = "Çim" Then
    S4.Range("A" & Satır3, "S" & Satır3).Value = S1.Range("A" & Hücre.Row, "S" & Hücre.Row).Value
    Satır3 = Satır3 + 1
    ElseIf Hücre.Offset(0, 1).Value = "ARP" And Hücre.Offset(0, 5).Value = "Kum" Then
    S5.Range("A" & Satır4, "S" & Satır4).Value = S1.Range("A" & Hücre.Row, "S" & Hücre.Row).Value
    Satır4 = Satır4 + 1
    End If
    End If
    Next
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    Set S4 = Nothing
    Set S5 = Nothing
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[mserler]

Sayın Korhan Ayhan üstadım ellerinize sağlık tam istediğim gibi olmuş,yardımınız için çok teşekkür ederim.
yanlız makro yeni verileri aktarırken eski aktarılmış verileri siliyor.bunun için ne yapabilirim.

 

[akkayah]

mserler arkadaşım uğraştığın konu karışık excell bu işlem için biçilmiş kaftan ama senin bu iş için 2007 excell ile uğraşmanı tavsiye ederim. Satır sayısı belli bir zaman sonra sana yetmeyecektir.
Arşiv istersen excell de 2 yıllık arşiv vardır macrona faydası olur.

 

[mserler]

akkayah arkadaşım mümkünse o arşivini mailime yollaya bilirmisin.

 

[akkayah]

benim adresim akkayah16@hotmail.com
Bana mail adresi verirsen dosyayı 2003 olara iki dosya halinde yollayabilirim.
Dosya 2007 versiyonda 27 mb. yer kaplıyor 2003 vesiyona dönüşürse toplamda 60 mb gibi bir yer kaplar sanıyorum