Soru Üç koşula göre mükerrer kayıt silme

okan32

okan32

Altın Üye
Katılım
12 Mayıs 2016
Mesajlar
386
Excel Vers. ve Dili
Ofis 2019- 32 Bit - Türkçe
Altın Üyelik Bitiş Tarihi
16-04-2026
S. A. Arkadaşlar ekteki örnek dosyamda belirttiğim şekilde üç koşula göre mükerrer kayıt yapıldığında kaydı silmek istiyorum.
 

Ekli dosyalar

N

numan şamil

Destek Ekibi
Destek Ekibi
Katılım
27 Ocak 2011
Mesajlar
1,231
Excel Vers. ve Dili
Ofis 2013 Türkçe
Merhaba
Denermisiniz
Kod: 
Sub mükerrersil()
Dim s2 As Worksheet
Dim a As Long
Set s2 = Sheets("Sayfa2")
Application.ScreenUpdating = False
For a = s2.[B65536].End(3).Row To 2 Step -1
If WorksheetFunction.CountIf(s2.Range("B2:B" & a), s2.Cells(a, "B")) > 1 And WorksheetFunction.CountIf(s2.Range("D2:D" & a), s2.Cells(a, "D")) > 1 And WorksheetFunction.CountIf(s2.Range("E2:E" & a), s2.Cells(a, "E")) > 1 Then s2.Range("B:E").Rows(a).Delete
Next a
Application.ScreenUpdating = True
End Sub
 
Son düzenleme:
okan32

okan32

Altın Üye
Katılım
12 Mayıs 2016
Mesajlar
386
Excel Vers. ve Dili
Ofis 2019- 32 Bit - Türkçe
Altın Üyelik Bitiş Tarihi
16-04-2026
Numan hocam teşekkür ederim yarın deneyip sonucundan bilgi veririm
 
okan32

okan32

Altın Üye
Katılım
12 Mayıs 2016
Mesajlar
386
Excel Vers. ve Dili
Ofis 2019- 32 Bit - Türkçe
Altın Üyelik Bitiş Tarihi
16-04-2026
numan şamil' Alıntı:
Merhaba
Denermisiniz
Kod: 
Sub mükerrersil()
Dim s2 As Worksheet
Dim a As Long
Set s2 = Sheets("Sayfa2")
Application.ScreenUpdating = False
For a = s2.[B65536].End(3).Row To 2 Step -1
If WorksheetFunction.CountIf(s2.Range("B2:B" & a), s2.Cells(a, "B")) > 1 And WorksheetFunction.CountIf(s2.Range("D2:D" & a), s2.Cells(a, "D")) > 1 And WorksheetFunction.CountIf(s2.Range("E2:E" & a), s2.Cells(a, "E")) > 1 Then s2.Range("B:E").Rows(a).Delete
Next a
Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...
Hocam bu koda ilave olarak eğer silinen veri varsa msgboxla bildirebilir mi acaba
 
Son düzenleme:
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,738
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

Hız olarak avantaj sağlayabilir.

C++: 
Option Explicit

Sub Mukerrer_Kayitlari_Sil()
    Dim S2 As Worksheet, Dizi As Object, Veri As Variant, Say As Long
    Dim Son As Long, X As Long, Aranan As String, Adet As Long, Zaman As Double
    
    Zaman = Timer
    
    Set Dizi = CreateObject("Scripting.Dictionary")
    Set S2 = Sheets("Sayfa2")
    
    Son = S2.Cells(S2.Rows.Count, 2).End(3).Row
    
    Veri = S2.Range("B2:E" & Son).Value
    
    ReDim Liste(1 To UBound(Veri), 1 To 4)
    
    For X = LBound(Veri) To UBound(Veri)
        Aranan = Veri(X, 1) & Veri(X, 3) & Veri(X, 4)
        If Not Dizi.Exists(Aranan) Then
            Say = Say + 1
            Dizi.Add Aranan, Say
            Liste(Say, 1) = Veri(X, 1)
            Liste(Say, 2) = Veri(X, 2)
            Liste(Say, 3) = Veri(X, 3)
            Liste(Say, 4) = Veri(X, 4)
        Else
            Adet = Adet + 1
        End If
    Next
    
    If Say > 0 Then
        S2.Range("B2:E" & S2.Rows.Count).ClearContents
        S2.Range("B2").Resize(Say, 4) = Liste
        If Adet > 0 Then
            MsgBox "Toplam " & Adet & " adet mükerrer kayıt silinmiştir." & Chr(10) & Chr(10) & _
                   "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
        Else
            MsgBox "Mükerrer kayıt bulunamadı!" & Chr(10) & Chr(10) & _
                   "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbCritical
        End If
    End If
    
    Set S2 = Nothing
    Set Dizi = Nothing
End Sub
 
okan32

okan32

Altın Üye
Katılım
12 Mayıs 2016
Mesajlar
386
Excel Vers. ve Dili
Ofis 2019- 32 Bit - Türkçe
Altın Üyelik Bitiş Tarihi
16-04-2026
Çok teşekkür ederim
Korhan Ayhan' Alıntı:
Deneyiniz.

Hız olarak avantaj sağlayabilir.

C++: 
Option Explicit

Sub Mukerrer_Kayitlari_Sil()
    Dim S2 As Worksheet, Dizi As Object, Veri As Variant, Say As Long
    Dim Son As Long, X As Long, Aranan As String, Adet As Long, Zaman As Double
   
    Zaman = Timer
   
    Set Dizi = CreateObject("Scripting.Dictionary")
    Set S2 = Sheets("Sayfa2")
   
    Son = S2.Cells(S2.Rows.Count, 2).End(3).Row
   
    Veri = S2.Range("B2:E" & Son).Value
   
    ReDim Liste(1 To UBound(Veri), 1 To 4)
   
    For X = LBound(Veri) To UBound(Veri)
        Aranan = Veri(X, 1) & Veri(X, 3) & Veri(X, 4)
        If Not Dizi.Exists(Aranan) Then
            Say = Say + 1
            Dizi.Add Aranan, Say
            Liste(Say, 1) = Veri(X, 1)
            Liste(Say, 2) = Veri(X, 2)
            Liste(Say, 3) = Veri(X, 3)
            Liste(Say, 4) = Veri(X, 4)
        Else
            Adet = Adet + 1
        End If
    Next
   
    If Say > 0 Then
        S2.Range("B2:E" & S2.Rows.Count).ClearContents
        S2.Range("B2").Resize(Say, 4) = Liste
        If Adet > 0 Then
            MsgBox "Toplam " & Adet & " adet mükerrer kayıt silinmiştir." & Chr(10) & Chr(10) & _
                   "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
        Else
            MsgBox "Mükerrer kayıt bulunamadı!" & Chr(10) & Chr(10) & _
                   "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbCritical
        End If
    End If
   
    Set S2 = Nothing
    Set Dizi = Nothing
End Sub
Genişletmek için tıkla ...
Çok teşekkür ederim Korhan Hocam süper olmuş
 
T

tahsinanarat

Altın Üye
Katılım
14 Mart 2005
Mesajlar
2,167
Excel Vers. ve Dili
Ofis 2019 Türkçe
Altın Üyelik Bitiş Tarihi
27-05-2028
@Sn. Korhan Hocam;
Kod: 
Sub Mukerrer_Kayitlari_Sil()
    Dim S2 As Worksheet, Dizi As Object, Veri As Variant, Say As Long
    Dim Son As Long, X As Long, Aranan As String, Adet As Long, Zaman As Double

    Zaman = Timer
    
    Set Dizi = CreateObject("Scripting.Dictionary")
    Set S2 = Sheets("Sayfa2")
    
    Son = S2.Cells(S2.Rows.Count, 2).End(3).Row

    Veri = S2.Range("a3:k" & Son).Value
    
    ReDim Liste(1 To UBound(Veri), 1 To 11)
    
    For X = LBound(Veri) To UBound(Veri)
        Aranan = Veri(X, 1) & Veri(X, 2) & Veri(X, 9)
        If Not Dizi.Exists(Aranan) Then
            Say = Say + 1
            Dizi.Add Aranan, Say
            Liste(Say, 1) = Veri(X, 1)
            Liste(Say, 2) = Veri(X, 2)
            Liste(Say, 3) = Veri(X, 3)
            Liste(Say, 4) = Veri(X, 4)
            Liste(Say, 5) = Veri(X, 5)
            Liste(Say, 6) = Veri(X, 6)
            Liste(Say, 7) = Veri(X, 7)
            Liste(Say, 8) = Veri(X, 8)
            Liste(Say, 9) = Veri(X, 9)
            Liste(Say, 10) = Veri(X, 10)
            Liste(Say, 11) = Veri(X, 11)
       Else
            Adet = Adet + 1
        End If
    Next
    
    If Say > 0 Then
        S2.Range("a3:k" & S2.Rows.Count).ClearContents
        S2.Range("a3").Resize(Say, 11) = Liste
        If Adet > 0 Then
            MsgBox "Toplam " & Adet & " adet mükerrer kayıt silinmiştir." & Chr(10) & Chr(10) & _
                   "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
        Else
            MsgBox "Mükerrer kayıt bulunamadı!" & Chr(10) & Chr(10) & _
                   "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbCritical
        End If
    End If

    Set S2 = Nothing
    Set Dizi = Nothing
End Sub
Buradaki mükerrer kayıtları silmek yerine Sayfa2 ye aktarmak istersek kodları buna göre revize edebilir misiniz. Teşekkürler
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,738
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Örnek dosya ekleyerek tarif eder misiniz?
 
T

tahsinanarat

Altın Üye
Katılım
14 Mart 2005
Mesajlar
2,167
Excel Vers. ve Dili
Ofis 2019 Türkçe
Altın Üyelik Bitiş Tarihi
27-05-2028
Sn. @Korhan Ayhan hocam örnek dosyayı ekte gönderiyorum, dediğim gibi data sayfasındaki A,B ve I sütunları aynı olan satırları Liste sayfasına aktarmak istiyorum, Mükerrer olan satırların hepsini.
Teşekkürler.
 

Ekli dosyalar

Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,738
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++: 
Option Explicit

Sub Mukerrer_Kayitlari_Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object, Veri As Variant, Say As Long
    Dim Son As Long, X As Long, Y As Byte, Aranan As String, Adet As Long, Zaman As Double
    
    Zaman = Timer
    
    Set Dizi = CreateObject("Scripting.Dictionary")
    Set S1 = Sheets("data")
    Set S2 = Sheets("liste")
    
    Son = S1.Cells(S2.Rows.Count, 1).End(3).Row
    
    If Son = 1 Then
        MsgBox "İşlem yapılacak kayıt bulunamadı!", vbExclamation
        Exit Sub
    End If
    
    If Son = 2 Then Son = 3
    
    Veri = S1.Range("A2:I" & Son).Value
    
    ReDim Liste(1 To UBound(Veri), 1 To 9)
    
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 1) <> "" Then
            Aranan = Veri(X, 1) & Veri(X, 2) & Veri(X, 9)
            If Not Dizi.Exists(Aranan) Then
                Dizi.Add Aranan, 1
            Else
                Dizi.Item(Aranan) = Dizi.Item(Aranan) + 1
            End If
        End If
    Next
    
    For X = LBound(Veri) To UBound(Veri)
        Aranan = Veri(X, 1) & Veri(X, 2) & Veri(X, 9)
        If Dizi.Item(Aranan) > 1 Then
            Say = Say + 1
            For Y = 1 To 9
                Liste(Say, Y) = Veri(X, Y)
            Next
        End If
    Next
    
    If Say > 0 Then
        S2.Select
        S2.Range("A2:I" & S2.Rows.Count).ClearContents
        S2.Range("A2").Resize(Say, 9) = Liste
        S2.Columns.AutoFit
        MsgBox "Toplam " & Say & " adet mükerrer kayıt tespit edilmiştir." & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    Else
        MsgBox "Mükerrer kayıt bulunamadı!" & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbCritical
    End If
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
End Sub
 
T

tahsinanarat

Altın Üye
Katılım
14 Mart 2005
Mesajlar
2,167
Excel Vers. ve Dili
Ofis 2019 Türkçe
Altın Üyelik Bitiş Tarihi
27-05-2028
Sn. @Korhan Ayhan hocam, elinize sağlık çok güzel çalışıyor, ancak mükerrer kayıt olmadığında Kayıt bulunamadı mesajını vermedi.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,738
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Kodu güncelledim. Son halini deneyiniz.
 
T

tahsinanarat

Altın Üye
Katılım
14 Mart 2005
Mesajlar
2,167
Excel Vers. ve Dili
Ofis 2019 Türkçe
Altın Üyelik Bitiş Tarihi
27-05-2028
Sn. @Korhan Ayhan Hocam, şimdi oldu, Çok teşekkür ediyorum. Elinize yüreğinize sağlık. Hayırlı akşamlar diliyorum.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst