Mükerrer Kayıtların Karşılığındaki Diğer Veriler

[deniz erkaya]

Selam ,
Birkaç ay önce mükerrer kayıtlar ile ilgili bir sorunumu sayın leventm cevaplamıştı.
Bu gün biraz daha farklı bir ihtiyaçla sizleri rahatsız ediyorum.Aşağıda eklediğim dosya üzerinde iki adet macro mevcut.Bunlardan birincisi " Listele " .Bu macro " RIM No. " sütununda birden fazla yer alan tüm kayıtları alt alta sıralıyor.Ancak yeni ihtiyaçta ;
Ã?ncelikli olarak sıralanan " RIM No." ların " data " sheet'inden kesilerek yanda bulunan " sonuç " sheet'ine yapıştırılması Ancak ;
Bu sıralama yapılırken sadece mükerrer RIM NO kayıtlarını değil , aynı zamanda " PRODUCT " sütununda bulunan ürünlerin de kontrol edilerek diğer sheet'e cut and paste yapılmasıgerekmekte.Þöyle ki , listele macrosu run edilince , mükerrer RIM NO'ları içerisinden sadece kartı olup da , aynı anda kredisi de ( İhtiyaç kredisi , konut kredisi , taşıt kredisi vs . ) olan kayıtların sonuç sheet'ine cut/paste yapılması ... Ã?rnek olarak ; Dosya üzerindeki " listele " butonunu çalıştırınca çıkan sonucun sadece " gri " olarak renklendirdiğim gibi olan kayıtların diğer sheet'e taşınması ,

Acaba anlatabildim mi ?
Kolay Gelsin ,
PS. sadece zip'lenen dosyaları indirebiliyorum.Cevabi dosyanızı zip'li attach ederseniz sevinirim.


Edit xxrt:"Daha Ã?nce leventm tarafından yardım edilen mükerrer kayıt hk" Soru başlığınız "Mükerrer Kayıtların Karşılığındaki Diğer Veriler" Olarak değiştirildi.

 

[veyselemre]

aşağıdaki kodları bir modül içine kopyala çalıştır
[vb:1:37a60a8405]
Sub aktar()
Set SD = Sheets("data")
Set Ss = Sheets("sonuç")
Ss.Cells.ClearContents
sonsat = SD.Cells(65536, 1).End(xlUp).Row
SD.Select
SD.Range(3 & ":" & sonsat).Copy
Ss.Select
Cells(3, 1).Select
ActiveSheet.Paste
sira = 4

'KREDİ VE DESTEK SİL
sonsat = Cells(65536, 1).End(xlUp).Row
For a = sonsat To 4 Step -1
If Cells(a, 2) = "KREDİ" Then Rows(a).Delete shift:=xlUp
If Cells(a, 2) = "DESTEK" Then Rows(a).Delete shift:=xlUp
Next a

'kart müşterisi olmayanları sil
sonsat = Cells(65536, 1).End(xlUp).Row
For a = sonsat To 4 Step -1
If Evaluate("SUMPRODUCT((F" & sonsat & ":F4=F" & a & ")*(B" & sonsat & ":B4=""KART""))") = 0 Then Rows(a).Delete shift:=xlUp
Next a

'TEK kayıtları sil
sonsat = Cells(65536, 1).End(xlUp).Row
For a = sonsat To 4 Step -1
If WorksheetFunction.CountIf(Range("F4:F65536"), Cells(a, 6)) = 1 Then Rows(a).Delete shift:=xlUp
Next

End Sub
[/vb:1:37a60a8405]