• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

okan32

okan32

Katılım
12 Mayıs 2016
Mesajlar
386
Excel Vers. ve Dili
Ofis 2019- 32 Bit - Türkçe
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

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:
Numan hocam teşekkür ederim yarın deneyip sonucundan bilgi veririm
 
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:
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
 
Ç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ş
 
@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
 
Örnek dosya ekleyerek tarif eder misiniz?
 
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

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
 
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.
 
Kodu güncelledim. Son halini deneyiniz.
 
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.
Geri
Üst