Aynı olan satırları silmek

[Gordawg]

Elimde 4000 satırlık bir exel dosyası var. tamamen telefon numaralarından oluşuyor. Ama bazı telefon numaraları tekrarlanmış. Bu tekrarlanan satırları silmenin kısa bir yolu varmıdır.

 

[Necdet]

Küçük, bir kaç satırlık örnek bir dosya ekleyin, hemen silecek makroyu yazalım.

Aşağıdaki kod A sütununda benzer olan kayıtları siler. (Verinin A sütununa göre sıralı olduğu varsayılarak)

Sub BenzerSil()
For i = [A65536].End(3).Row To 2 Step -1
If Cells(i, "A") = Cells(i - 1, "A") Then Rows(i).Delete
Next i
End Sub

 

[Gordawg]

Verdiğiniz kod çalıştı. Benzerler silindi. Teşekkürler

 

[alpadem]

Merhaba Sayın Necdet Bey,

Eğer veriler sıralı değil ise nasıl bir yol izlememiz gerekir, yada bunun için yazılacak makro nasıl olmalıdır. Teşekkürler..

 

[Necdet]

Merhaba,

Veriler sıralı değilse sıralamak gerekir doğal olarak.

Range("A2:G100").sort key1:=[A2]

gibi bir sıralama satırı koymak gerek.

 

[herbil]

Merhaba Sayın Necdet Bey,

Eğer veriler sıralı değil ise nasıl bir yol izlememiz gerekir, yada bunun için yazılacak makro nasıl olmalıdır. Teşekkürler..

Sırayı belirten bir sütun eklenir,
Daha sonra Telefon no suna göre sıralanır,
Silme işlemi yapılır,
Sonra sırayı belirten sütuna göre sıralama yapılarak eski sıra geri getirilir.

diğer bir makro şu şekilde olabilir, ama bu kod un çalışması zaman alır.

Sub Ayni_satirlari_sil()


kaca_kadar = 100

For i = 1 To kaca_kadar

For j = 1 To kaca_kadar

If j = i Then
Else
If Range("A" & i) = Range("A" & j) Then Rows(j).Delete
End If

Next j


Next i


End Sub

Burada kaca_kadar değeri ilgili satır sayısını belirtiyor.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodla verilerin sıralı olması önemli değildir. Sayma işlemi yaparak mükerrer kayıtları siler.

A sütunundaki mükerrer verileri teke indirir.

Sub MÜKERRER_KAYITLARI_SİL()
    For X = [A65536].End(3).Row To 1 Step -1
    If WorksheetFunction.CountIf(Range("A1:A" & X), Cells(X, "A")) > 1 Then Rows(X).Delete
    Next
    MsgBox "MÜKERRER KAYITLAR SİLİNMİŞTİR.", vbInformation
End Sub

Birden fazla sütuna göre mükerrer kayıt kontrolü yaparak kayıtları teke indirir.

[LEFT]Sub MÜKERRER_KAYITLARI_SİL()
    [IV:IV].ClearContents
    [IV1] = "=A1 & B1 & C1 & D1 & E1 & F1 & G1"
    [IV1].AutoFill Destination:=Range("IV1:IV" & [A65536].End(3).Row), Type:=xlFillDefault
    [IV:IV].Value = [IV:IV].Value
    For X = [IV65536].End(3).Row To 1 Step -1
    If WorksheetFunction.CountIf(Range("IV1:IV" & X), Cells(X, "IV")) > 1 Then Rows(X).Delete
    Next
    [IV:IV].ClearContents
    MsgBox "MÜKERRER KAYITLAR SİLİNMİŞTİR.", vbInformation
End Sub

[/LEFT]

 

[esmatekel]

Benzer Kayıt Silinesi

Selamlar,

Aşağıdaki kodla verilerin sıralı olması önemli değildir. Sayma işlemi yaparak mükerrer kayıtları siler.

A sütunundaki mükerrer verileri teke indirir.

Sub MÜKERRER_KAYITLARI_SİL()
    For X = [A65536].End(3).Row To 1 Step -1
    If WorksheetFunction.CountIf(Range("A1:A" & X), Cells(X, "A")) > 1 Then Rows(X).Delete
    Next
    MsgBox "MÜKERRER KAYITLAR SİLİNMİŞTİR.", vbInformation
End Sub

Birden fazla sütuna göre mükerrer kayıt kontrolü yaparak kayıtları teke indirir.

[LEFT]Sub MÜKERRER_KAYITLARI_SİL()
    [IV:IV].ClearContents
    [IV1] = "=A1 & B1 & C1 & D1 & E1 & F1 & G1"
    [IV1].AutoFill Destination:=Range("IV1:IV" & [A65536].End(3).Row), Type:=xlFillDefault
    [IV:IV].Value = [IV:IV].Value
    For X = [IV65536].End(3).Row To 1 Step -1
    If WorksheetFunction.CountIf(Range("IV1:IV" & X), Cells(X, "IV")) > 1 Then Rows(X).Delete
    Next
    [IV:IV].ClearContents
    MsgBox "MÜKERRER KAYITLAR SİLİNMİŞTİR.", vbInformation
End Sub

[/LEFT]

Selamlar

Yukarıda Belirttiğiniz Kodun Bir Değişiği VArmı Mesela
Bir Sütünda İkitane MEhmet Bir TAne Ahmet Yazısı Var Biz Eğer Varsa Böyle Bir Kodu Yazıp Çalıştırdığımızda Birbirine Benzeyen Mehmet Satırlarını Slip Geiye Sadece Benzeri Olmayan Ahmet Satırını Kalmasını Sağlayabilirmiyiz Teşekkürler

 

[Korhan Ayhan]

Selamlar,

Sn. esmatekel,

İstediğiniz işlem için aşağıdaki kodu kullanabilirsiniz. A sütunundaki benzer kayıtların tamamını siler sadece hiç benzeri olmayan kayıtlar kalır.

Sub BENZER_KAYITLARI_SİL()
    For X = 1 To [A65536].End(3).Row
    SAY = WorksheetFunction.CountIf([A:A], Cells(X, 1))
    If SAY > 1 Then
    Columns(1).Replace What:=Cells(X, 1), Replacement:=""
    End If
    Next
    Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    MsgBox "İŞLEMİNİZ TAMAMLANMIŞTIR.", vbInformation
End Sub

 

[quman]

Verdiğiniz bilgiler için teşekkürler.

 

[muratkivilcim]

yardımmm

Selamlar,

Sn. esmatekel,

İstediğiniz işlem için aşağıdaki kodu kullanabilirsiniz. A sütunundaki benzer kayıtların tamamını siler sadece hiç benzeri olmayan kayıtlar kalır.

Sub BENZER_KAYITLARI_SİL()
    For X = 1 To [A65536].End(3).Row
    SAY = WorksheetFunction.CountIf([A:A], Cells(X, 1))
    If SAY > 1 Then
    Columns(1).Replace What:=Cells(X, 1), Replacement:=""
    End If
    Next
    Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    MsgBox "İŞLEMİNİZ TAMAMLANMIŞTIR.", vbInformation
End Sub

üstad bu makronun bana 6 sütuna göre olanı lazım mümkünmüdür.

 

[Korhan Ayhan]

Selamlar,

Örnek dosya ekleyip hangi kriterlere göre silme işlemini yapacağınızı belirtirseniz yardımcı olmaya çalışırız.

 

[aygun78]

mükerrer kayıtları başka sayfaya fisteleme

arkadaşlar benimde mükerrerlerle ilgili yardıma ihtiyacım var.forumda aramamama rağmen iki sütün baz alınarak yapılan bi mükerrer kayıt örneği bulamadım .
ekte göndermiş olduğum dosyada anne adı ve soyadı (ayrı ayrı) verilerini kullanarak sayfa ikideki anne adı ve soyadlarıyla karşılaştırıp sayfa 2 de olmayanları sayfa3 e listelemek istiyorum.ekteki dosyadada ayrıntılı açıklama yaptım yardımlarınız için şlimdiden teşekkürler

 

[g_demir]

Sub BENZER_KAYITLARI_SİL()
For X = 1 To [A65536].End(3).Row
SAY = WorksheetFunction.CountIf([A:A], Cells(X, 1))
If SAY > 1 Then
Columns(1).Replace What:=Cells(X, 1), Replacement:=""
End If
Next
Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
MsgBox "İŞLEMİNİZ TAMAMLANMIŞTIR.", vbInformation
End Sub

bu guzel bir kod olmuş gercekten işe yarıyor
fakat benzer adların hepsini siliyor
bir tanesi kalması lazım degilmi ?

 

[yst10]

Selamlar,

Aşağıdaki kodla verilerin sıralı olması önemli değildir. Sayma işlemi yaparak mükerrer kayıtları siler.

A sütunundaki mükerrer verileri teke indirir.

Sub MÜKERRER_KAYITLARI_SİL()
    For X = [A65536].End(3).Row To 1 Step -1
    If WorksheetFunction.CountIf(Range("A1:A" & X), Cells(X, "A")) > 1 Then Rows(X).Delete
    Next
    MsgBox "MÜKERRER KAYITLAR SİLİNMİŞTİR.", vbInformation
End Sub

Sn. Korhan bey,
Makro mükemmel çalışıyor. Bir sorum olacak, silme işlemi ile beraber, adetleri de yazdırmak mümkün mü? mesela A kolonuna göre değil de c kolonuna göre süzme ve silme işlemini yaptığında benzer kayıtlardan tek kalan kaydın yanındaki kolona veya 2 kolon sonrasına o kayıttan silme işleminden önce kaçtane olduğunu yazabilir mi? Umarım anlatabilmişimdir.
İlginize teşekkür ederim.
Saygılar.​

 

[Korhan Ayhan]

Selamlar,

Sn. yst10,

Ekteki örnek dosyayı incelermisiniz.

 

[yst10]

Sn:Korhan Bey,
Çok teşekkür ederim, size sorduğumdan beri uğraşıp duruyordum. ilaç gibi geldi. Ellerinize, bilginize sağlık.
Sevgiler, saygılar.
Yavuz Tümer

 

[yst10]

Korhan hocam,
Bir ayrıntı; tüm satırın silinmesi yerine, sadece tablonun olduğu kısımda silinmesini istersem, çok şey istemiş olurmuyum?

 

[Korhan Ayhan]

Selamlar,

Bu durumda önerdiğim koddaki Rows(X).Delete satırını aşağıdaki ile değiştirip kullanabilirsiniz.

    Range("C" & X).Delete Shift:=xlUp

 

[yst10]

Selamlar, iyi Pazarlar Korhan hocam,

Verdiğiniz kodlarla son durum şu şekilde oldu ama bu da hata veriyor. sanırım Range kısmını beceremedim. Kırmızı yazılı kısımda hata veriyor.
Elimdeki örneklerede baktım ama, benzer bir seçim şekli bulamadım.
Aslında can sıkmaya başladım, farkındayım. Ama takıldı kafama işte..
Var ise yapabileceğiniz bir şey, müteşekkir olacağım.
Yavuz
[S2:S65536].ClearContents
For X = [K65536].End(3).Row To 1 Step -1
SAY = WorksheetFunction.CountIf(Range("K1:K" & X), Cells(X, "K"))
If SAY > 1 Then
Set BUL = Columns(11).Find(Cells(X, "K"), LookAt:=xlWhole)
If Not BUL Is Nothing Then
Range("J:S" & X).Delete Shift:=xlUp
If Cells(BUL.Row, "S") = "" Then Cells(BUL.Row, "S") = SAY
End If
End If
Next
Columns("L:L").Delete

MsgBox "MÜKERRER KAYITLAR SİLİNMİŞTİR.", vbInformation