Birden fazla sütunda mükerrer satırları silme ?

[koleksiyoncu1980]

Ekteki dosyadaki verilerde birden fazla olan ve örnek olarak işaretlediğimiz satırlar var. İstediğimiz şudur ;
B,C ve D sütunlarının hepsinde de aynı olup tekrar edilen veriler tespit edilsin ve ilgili tüm satır silinerek teke indirilsin
Bu veriler örnektir ve zamanla çok daha fazla veri girişi yapılacaktır bu yüzden eğer mümkünse bir düğme olursa yeni veriyi her eklediğimizde makroyu çalıştırıp düğmeye basıp silme işlemini gerçekleştirebiliriz.

Yardımcı olacak excel üstadlarına şimdiden teşekkür ederiz

 

[halit3]

Ekteki dosyadaki verilerde birden fazla olan ve örnek olarak işaretlediğimiz satırlar var. İstediğimiz şudur ;
B,C ve D sütunlarının hepsinde de aynı olup tekrar edilen veriler tespit edilsin ve ilgili tüm satır silinerek teke indirilsin
Bu veriler örnektir ve zamanla çok daha fazla veri girişi yapılacaktır bu yüzden eğer mümkünse bir düğme olursa yeni veriyi her eklediğimizde makroyu çalıştırıp düğmeye basıp silme işlemini gerçekleştirebiliriz.

Yardımcı olacak excel üstadlarına şimdiden teşekkür ederiz

Kod veri çokluğuna göre birazcık zaman almaktadır.
not:Örnek dosyanızda sadece 1 adet mükerrer satır var.

kod :

Sub deneme2()
Dim say(65000)
deg1 = 1
For r = 2 To Cells(Rows.Count, "B").End(3).Row
aranan1 = Cells(r, "b").Value & Cells(r, "c").Value & Cells(r, "d").Value
sat = 1
For i = r To Cells(Rows.Count, "B").End(3).Row
aranan2 = Cells(i, "b").Value & Cells(i, "c").Value & Cells(i, "d").Value
If aranan2 = aranan1 Then
If sat > 1 Then
deg1 = deg1 + 1
say(deg1) = i
End If
sat = sat + 1
End If
Next i
Next r
For j = deg1 To 2 Step -1
MsgBox say(j) & " satır mükerrer silinecek"
Rows(say(j)).Delete Shift:=xlUp
Next j
End Sub

 

[Korhan Ayhan]

Merhaba,

Alternatif olarak aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub MÜKERRER_KAYITLARI_SİL()
    Dim X As Long
 
    Application.ScreenUpdating = False
 
    Range("AI:AJ").Delete
    Range("AI1") = "LİSTE"
    Range("AJ1") = "SAY"
 
    With Range("AI2:AI" & Cells(Rows.Count, 1).End(3).Row)
        .Formula = "=B2&C2&D2"
        .Value = .Value
    End With
 
    With Range("AJ2:AJ" & Cells(Rows.Count, 1).End(3).Row)
        .Formula = "=COUNTIF(AI$2:AI2,AI2)"
        .Value = .Value
    End With
 
    Range("A1").AutoFilter
    Range("A1").AutoFilter Field:=36, Criteria1:=2
 
    If Cells(Rows.Count, 1).End(3).Row > 1 Then
        Range("A2:A" & Cells(Rows.Count, 1).End(3).Row).EntireRow.Delete
    End If
 
    Range("A1").AutoFilter
    Range("AI:AJ").Delete
 
    Application.ScreenUpdating = True
 
    MsgBox "Mükerrer kayıtlar silinmiştir.", vbInformation
End Sub

 

[koleksiyoncu1980]

halit bey öncelikle ilgilendiğiniz için teşekkür ederiz ve evet mükerrer örneği verirken 1 tane yazmışız
kodu dosyaya entegre edemedik rica etsek siz dosyaya makro şeklinde entegre edip bir de düğme koyabilir misiniz ?
o düğmeye basınca silsin istiyoruz

çok teşekkürler

 

[koleksiyoncu1980]

Merhaba,

Alternatif olarak aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub MÜKERRER_KAYITLARI_SİL()
    Dim X As Long
 
    Application.ScreenUpdating = False
 
    Range("AI:AJ").Delete
    Range("AI1") = "LİSTE"
    Range("AJ1") = "SAY"
 
    With Range("AI2:AI" & Cells(Rows.Count, 1).End(3).Row)
        .Formula = "=B2&C2&D2"
        .Value = .Value
    End With
 
    With Range("AJ2:AJ" & Cells(Rows.Count, 1).End(3).Row)
        .Formula = "=COUNTIF(AI$2:AI2,AI2)"
        .Value = .Value
    End With
 
    Range("A1").AutoFilter
    Range("A1").AutoFilter Field:=36, Criteria1:=2
 
    If Cells(Rows.Count, 1).End(3).Row > 1 Then
        Range("A2:A" & Cells(Rows.Count, 1).End(3).Row).EntireRow.Delete
    End If
 
    Range("A1").AutoFilter
    Range("AI:AJ").Delete
 
    Application.ScreenUpdating = True
 
    MsgBox "Mükerrer kayıtlar silinmiştir.", vbInformation
End Sub

malesef korhan bey bu da olmadı
siz entegre edebilir misiniz ? ve bir de düğme olsa tıklayınca silse böyle bir imkanımız var mı

 

[Korhan Ayhan]

Olmaması ilginç gerçekten...

Oysa ki kodları deneyerek göndermiştim.

Neyse ekteki dosyayı inceleyiniz.

 

[koleksiyoncu1980]

Olmaması ilginç gerçekten...

Oysa ki kodları deneyerek göndermiştim.

Neyse ekteki dosyayı inceleyiniz.

kusura bakmayın bu konularda beceriksiz olduğumuz için yapamadık
çok teşekkür ederiz tam istediğimiz gibi olmuş sağolun

iyi çalışmalar

 

[halit3]

halit bey öncelikle ilgilendiğiniz için teşekkür ederiz ve evet mükerrer örneği verirken 1 tane yazmışız
kodu dosyaya entegre edemedik rica etsek siz dosyaya makro şeklinde entegre edip bir de düğme koyabilir misiniz ?
o düğmeye basınca silsin istiyoruz

çok teşekkürler

2 nolu mesaja dosyanızı ekledim.

 

[koleksiyoncu1980]

2 nolu mesaja dosyanızı ekledim.

size de çok teşekkür ederiz halit bey
sizin dosyanızda çalışıyor

iyi çalışmalar dileriz