Mükerrer Kayıt için Yardım Talebi...

[yegan]

Merhaba arkadaşlar...Forumda verilen mükerrer kayıt örnekleri dosyasını inceledim.Benim ihtiyacımı tam olarak gideremiyeceğini düşündüğüm için örnek dosyamı buraya sizden yardım istemeye karar verdim.Ben A sütunundaki aynı isimleri bulan ve bu isimleri silmeden bana gösteren bir kod veya formül rica ediyorum.Çünkü aynı isimlere sahip farklı kişiler de olabiliyor.Ya da yanyana A,B,C sütunu bilgileri aynı olan kişileri gösteren bir kod veya formül rica ediyorum.(Örnek liste 3000 kişilik listenin aslı ise 50.000 kişilik.)Yardımınız için şimdiden çok teşekkürler...

 

[mehmett]

Bu konuda forumda pek çok örnek var fakat siz bulamadınız demek ki. Mükerrer kayıtları tespit etmenin çok yolu var. Bunlardan biri Koşullu Biçimlendirme.

A2 hücresini aşağıdaki formül ile Koşullu Biçimlendirin ve aynı biçimi A3000 satırına kadar kopyalayın.

=EĞERSAY($A$2:$A$3000;A2)>1

 

[yegan]

Mehmet Bey çok teşekkür ederim.Sizden bir istirhamım daha olacak.Acaba bu gönderdiğim örnek dosyaya göre A,B,C sütunlarının üçünü birden denetleyerek aynı satırdadaki ve ve sütunlardaki bilgiler aynıysa silmek mümkün mü?Tam izah edemiyor olabilirim.Örneğin A3,B3,C3 hücrelerindeki bilgileri bir bütün olarak göz önüne alıp eğer A4,B4,C4 hücrelerindeki bilgiler ile aynıysa silmek mümkün olur mu?İlginiz ve yardımlarınız için size ve tüm arkadaşlara şimdiden teşekkürler...

 

[Korhan Ayhan]

Selamlar,

Ekte örnek dosyanızda gerekli düzenlemeleri yaptım. Butona bastığınızda mükerrer kayıtları renklendirecek ve G sütununa "MÜKERRER" yazısını ekleyecektir. Bu işlemden sonra G sütununa göre süzüp ekranınızda kalanları silebilirsiniz. Aslında direk kodlar yardımıylada silebilirdik fakat ben mükerrer kayıtları kontrol etmeniz açısından silme işlemini size bıraktım. Dilerseniz koda bu eklemeyide yapabiliriz.

 

[yegan]

Öncelikle yardımınız için çok teşekkür ediyorum.Ancak kodu benim daha büyük hacimli çalışma sayfama eklemeye kalkıştığımda sorun yaşadım.Yani sizin örnek dosyanızdaki düzgün bir sonuç elde edemedim.Acaba kodu yanlış aktarmış olabilir miyim diye düşünerek bu sefer verilerin tamamını sizin örnek dosyanıza aktardım ancak aynı sorunu gene yaşadım.Belki benim yetersizliğimden kaynaklanan bir sorunda yaşamış olabilirim.Sizden ricam aşağıda upload linkine yüklediğim çalışma dosyamın tamamı üzerinde kodunuzu tekrar gözden geçirivermeniz.Sizin ve tüm arkadaşların yardım ve ilgileri için çok teşekkür ediyorum.Saygılar...


http://www.megaupload.com/tr/?d=5OZ6Z2PH

http://www.dosyaekle.com/do2.php?x=deneme.rar

http://d.turboupload.com/d/1326287/deneme.rar.html

 

[yegan]

Arkadaşlar biraz aciliyetim var yardımcı olabilecek misiniz?

 

[Korhan Ayhan]

Selamlar,

Dosyanızı link vermeden sıkıştırıp direk foruma eklermisiniz.

 

[yegan]

Selamlar,

Dosyanızı link vermeden sıkıştırıp direk foruma eklermisiniz.

Sayın COST_CONTROL forumun belirlediği eklenti limiti rar uzantılı dosyalar için 500 kb.5 mb kusurluk bu dosyayı sıkıştırmak için değişik seçeneklerle o kadar uğraşmama rağmen ancak 1,20 mb'a kadar sıkıştırabildim.Dolayısıyla eklenti olarak ekleyemedim.Eğer bu şekilde dosyayı alamıyorsanız isterseniz bana bırakacağınız bir emaile gönderebilirim.İlginiz için çok teşekkür ederim...

 

[Korhan Ayhan]

Selamlar,

En son eklediğiniz örnek dosyaya göre ilk verdiğim kod kendi bilgisayarımda yaklaşık 12 dakikada işlemi tamamladı. Kodu dahada hızlandırabilmek için excelin gelişmiş filtreleme yöntemini kullanarak aşağıdaki kodu oluşturdum. Bu kodu çalıştırdığımda 5 dakika gibi bir sürede işlemi tamamlandı. Mükerrer kayıtları ayıkladıktan sonra Sayfa2 ye aktarıyor. Umarım son önerdiğim kod işinize yarar.

Sub MÜKERRER_KAYITLARI_AYIKLA()
    BAŞLANGIÇ = Timer
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    S2.Cells.Clear
    SON_SATIR = S1.[A65536].End(3).Row
    S1.Range("A1:C" & SON_SATIR).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    [A1:F1].Select
    Range(Selection, Selection.End(xlDown)).Copy
    S2.Select
    [A1].Select
    ActiveSheet.Paste
    [A1].Select
    S1.Select
    S1.ShowAllData
    [A1].Select
    S2.Select
    Application.CutCopyMode = False
    BİTİŞ = Timer
    SÜRE = Format((BİTİŞ - BAŞLANGIÇ) / 60, "#,##0.00")
    MsgBox "İŞLEM SÜRESİ :   " & SÜRE & " DAKİKADIR."
    MsgBox "MÜKERRER KAYITLAR LİSTENİZDEN AYIKLANMIŞTIR.", vbInformation
End Sub

 

[yegan]

Sayın COST_CONTROL bu kod harika çalıştı.Beni büyük bir zahmetten kurtardınız.Çok teşekkürler...

 

[Gökhan Gümüş]

Sayın COST_CONTROL bu kod form üzerine atanan bir commadbutton ile yapmak mümkünmü.Yani sayfayı hiç göstermeden ve veri sayfası üzerinde silinen mükerrerlerden sonra ikinci sayfaya aktarma olmadan.

 

[Korhan Ayhan]

Selamlar,

Bahsettiğiniz konuları içeren örnek bir dosya eklerseniz. İstediğiniz işlemin olup olamayacağı konusunda fikrimi söyleyebilirim.

 

[Gökhan Gümüş]

Selamlar,

Bahsettiğiniz konuları içeren örnek bir dosya eklerseniz. İstediğiniz işlemin olup olamayacağı konusunda fikrimi söyleyebilirim.

Sayın Cost_Control ilginize şimdiden teşekkürler,dosyayı ekliyorum.Selamlar

 

[Korhan Ayhan]

Selamlar,

Örnek olarak eklediğiniz dosyanıza göre B:G sütunlarındaki verilerin tamamı için mükerrer kayıt kontrolü yaptırdım. Aşağıdaki kodu formunuzdaki ilgili butonun kod kısmına uygulayıp denermisiniz. Umarım işinize yarar.

Private Sub CommandButton1_Click()
    Application.Visible = False
    Set S1 = Sheets("Sayfa1")
    S1.Select
    SON_SATIR = [A65536].End(3).Row
    KAYIT_SAY_1 = WorksheetFunction.CountA([B2:B65536])
    If KAYIT_SAY_1 = 0 Then GoTo SON
    [H2] = "=SUBSTITUTE(B2&C2&D2&E2&F2&G2,"" "","""")"
    If KAYIT_SAY_1 > 1 Then [H2].AutoFill Destination:=Range("H2:H" & SON_SATIR), Type:=xlFillDefault
    For X = [A65536].End(3).Row To 2 Step -1
    KRİTER = Cells(X, "H")
    If WorksheetFunction.CountIf(Range("H2:H" & SON_SATIR), KRİTER) > 1 Then Rows(X).Delete
    Next
    KAYIT_SAY_2 = WorksheetFunction.CountA([B2:B65536])
    If KAYIT_SAY_2 = 0 Then Exit Sub
    If KAYIT_SAY_2 = 1 Then [A2] = 1
    If KAYIT_SAY_2 = 2 Then [A2] = 1: [A3] = 2
    If KAYIT_SAY_2 > 2 Then
    [A2] = 1: [A3] = 2: [A2:A3].AutoFill Destination:=Range("A2:A" & SON_SATIR), Type:=xlFillDefault
    End If
    Range("H2:H" & SON_SATIR) = ""
    Application.Visible = True
    MsgBox "Mükerrer kayıtlar listenizden ayıklanmıştır.", vbInformation
    Exit Sub
SON: MsgBox "Kayıt bulunamamıştır.", vbExclamation
End Sub

 

[Gökhan Gümüş]

Sayın Cost_Control;
Sen bir harikasın.Ellerine sağlık.Bu kod çok işime yaradı.Sağolasın.

 

[omurkorkmaz]

adminlerden rica ediyorum silinen dosyaların olduğu konularda silinirse form daha işleyişli hale gelir

 

[Binbasi1]

aynı verileri topla

mrb bense mükerer satırları sütuna bakarak toplatmak istiyorum dosyam ekte b sütunundaki verilerre göre c d e f g h ı sütunlarını aynı olanlarını nasıl toplatırıp yen liste oluşturabilirim

 

[halit3]

aşağıdaki mesajda düzeltildi

 

[Binbasi1]

ellerinize sağlık super olmuş ama bi kusur kaldı sondaki muayene toplamı benim örenek muayene ücreti olarak geçiyor sayfa 1 yazılı muayene kat.payı ücretleride topladımı hiç sorun kalmıyacak genede teşekkür ederim güzel çalışma olmuş

 

[halit3]

genel toplamımı alınacak