mükerrer

[numan şamil]

Sub mükerrersil()
Dim S1 As Worksheet
Dim a As Long
Set S1 = Sheets("Sayfa1")
Application.ScreenUpdating = False
For a = S1.[BD65536].End(3).Row To 4 Step -1
If WorksheetFunction.CountIf(S1.Range("BD4:BD" & a), S1.Cells(a, "BD")) > 1 Then S1.Range("BA:BD").Rows(a).Delete
Next
Application.ScreenUpdating = True
End Sub

Merhabalar Arkadaşlar
Yukarıdaki kodlarda yapılan işi daha hızlı yapacak kodlara ihtiyacım var
yardımcı olan olursa sevinirim

 

[Necdet]

Merhaba,

Sub Deneme()

    Dim i As Long
    i = Cells(Rows.Count, "BD").End(3).Row
    
    Range("BD4:BD" & i).RemoveDuplicates Columns:=1, Header:=xlNo
    
End Sub

 

[veyselemre]

Sub test()

    Dim rng As Range, silRng As Range, elem
    Set rng = Range("BD4:BD" & Cells(Rows.Count, "BD").End(3).Row)
    Set silRng = Range("BD1")
    
    With CreateObject("Scripting.Dictionary")
        For Each elem In rng
            If Not .exists(elem.Value) Then
                .Item(elem.Value) = Null
            Else
                Set silRng = Union(silRng, elem)
            End If
        Next elem
        Set silRng = Intersect(rng, silRng)
    End With
    
    If Not silRng Is Nothing Then silRng.EntireRow.Delete

End Sub

 

[numan şamil]

Sn Necdet
Sn Veyselemre
Çok Teşekkür ederim

 

[numan şamil]

Necdet bey, Veyselemre Bey
BD sutunundaki mükerrerlere göre
BA:BE arasındaki satırı silecek olursak
kodları nasıl düzenlemeliyiz

:

 

[numan şamil]

Sn Veyselemre cevabınız için teşekkürler
Ancak yaptığım denemede sadece BD sutunundaki benzerleri siliyor
BD sutunundaki mükererlere göre BA:BE arasındaki satırı silmesi gerekiyor

 

[numan şamil]

Nasıl olmasını istediğimi ekli dosyada belirttim

 

[veyselemre]

Sub test()

    Dim rng As Range, silRng As Range, elem
    Set rng = Range("BD4:BD" & Cells(Rows.Count, "BD").End(3).Row)
    Set silRng = Range("BD1")
    
    With CreateObject("Scripting.Dictionary")
        For Each elem In rng
            If Not .exists(elem.Value) Then
                .Item(elem.Value) = Null
            Else
                Set silRng = Union(silRng, elem.Offset(, -3).Resize(, 5))
            End If
        Next elem
        Set silRng = Intersect(rng.Offset(, -3).Resize(, 5), silRng)
    End With
    
    If Not silRng Is Nothing Then silRng.Delete xlUp

End Sub

 

[numan şamil]

Sn Veyselemre çok teşekkürler
Tam istediğim gibi çalışıyor

 

[numan şamil]

Necdet bey sizin kodlarda
BD sutunundaki mükerrerlere göre
BA:BE arasındaki satırı silecek olursak
kodları nasıl düzenlemeliyiz