Soru Mükerrer Üst Satırlar

[leonadies]

Merhaba Arkadaşlar;

Bir makroya ihtiyacım var. A sütununda veri girdikçe üst taraflarda eğer mükerrer veri varsa o satırı komple silsin istiyorum. Mesela bu örnekte A3 satırı silinsin bekliyorum.

Yardımcı olur musunuz?

 

[Muzaffer Ali]

Merhaba.

Sayfanın kod kısmına aşağıdaki kodu kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Bul As Range
    If Not Intersect(Target, Range("A:A")) Is Nothing Then
        Set Bul = Range("A1:A" & Target.Row - 1).Find(what:=Target.Text, lookat:=xlWhole)
        If Not Bul Is Nothing Then
            Rows(Bul.Row).Delete
        End If
    End If
End Sub

 

[leonadies]

@Muzaffer Ali üstadım eline sağlık. Fark etttim ki üstte çok sayıda mükerrer olunca sadece en üsttekini siliyor. Benim arzum her zaman en alttaki kalsın. üstte ne kadar mükerrer satır varsa hepsni silsin.

Yada sorumu bir buton yardımı ile hep en alttaki kalıcak şekle nasıl ceviririz diye değiştireyim.

 

[Muzaffer Ali]

O zaman aşağıdaki kodu kullanın.

Sub test()
    Dim Bul As Range
    Dim Bak As Long
    For Bak = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
        Set Bul = Range("A1:A" & Bak - 1).Find(what:=Cells(Bak, "A"), lookat:=xlWhole)
        If Not Bul Is Nothing Then
            Rows(Bul.Row).Delete
        End If
    Next
End Sub

 

[leonadies]

Teşekkürler @Muzaffer Ali Üstadım

 

[veyselemre]

Sub test()

    Dim bulundu As Boolean, i&, lRow&, ky
    lRow = Cells(Rows.Count, 1).End(3)
    With CreateObject("Scripting.Dictionary")
        For i = lRow To 1 Step -1
            ky = Cells(i, 1).Value
            If .exists(ky) Then
                Cells(i, 1).Value = ""
                bulundu = True
            Else
                .Item(ky) = i
            End If
        Next i
        If bulundu Then Range("A1:A" & lRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With

End Sub

 

[Muzaffer Ali]

Rica ederim. Kolay gelsin.