mükerrer

numan şamil

Destek Ekibi
Destek Ekibi
Katılım
27 Ocak 2011
Mesajlar
1,231
Excel Vers. ve Dili
Ofis 2013 Türkçe
Kod:
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

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,372
Excel Vers. ve Dili
Ofis 365 Türkçe
Merhaba,
Kod:
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

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,646
Excel Vers. ve Dili
Pro Plus 2021
Kod:
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

Destek Ekibi
Destek Ekibi
Katılım
27 Ocak 2011
Mesajlar
1,231
Excel Vers. ve Dili
Ofis 2013 Türkçe
Necdet bey, Veyselemre Bey
BD sutunundaki mükerrerlere göre
BA:BE arasındaki satırı silecek olursak
kodları nasıl düzenlemeliyiz

:
 
Son düzenleme:

numan şamil

Destek Ekibi
Destek Ekibi
Katılım
27 Ocak 2011
Mesajlar
1,231
Excel Vers. ve Dili
Ofis 2013 Türkçe
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

Destek Ekibi
Destek Ekibi
Katılım
27 Ocak 2011
Mesajlar
1,231
Excel Vers. ve Dili
Ofis 2013 Türkçe
Nasıl olmasını istediğimi ekli dosyada belirttim
 

Ekli dosyalar

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,646
Excel Vers. ve Dili
Pro Plus 2021
Kod:
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

Destek Ekibi
Destek Ekibi
Katılım
27 Ocak 2011
Mesajlar
1,231
Excel Vers. ve Dili
Ofis 2013 Türkçe
Sn Veyselemre çok teşekkürler
Tam istediğim gibi çalışıyor
 

numan şamil

Destek Ekibi
Destek Ekibi
Katılım
27 Ocak 2011
Mesajlar
1,231
Excel Vers. ve Dili
Ofis 2013 Türkçe
Necdet bey sizin kodlarda
BD sutunundaki mükerrerlere göre
BA:BE arasındaki satırı silecek olursak
kodları nasıl düzenlemeliyiz
 
Üst