Soru Mükerrer Satır (Üst Satırları Silme)

[leonadies]

Arkadaşlar forumu baya inceledim ancak mükerrer silme işinde tam istediğimi bulamadım.

İsteğim Makro butona basınca A:A sütununda yer alan bilgilerde en alttaki satır kalacak şekilde üstteki mükerrerleri sildirmeyi sağlamak.

 

[Ömer]

Merhaba,

Linki inceleyiniz.

eski mükerrer kayıtları silmek

mükerrer olan kayıtları yinelenenleri kaldır ile kaldırıyorum. ama son eklenenleri kaldırıyor. ben önce eklenenleri nasıl kaldırabilirim.

excel.web.tr

.

 

[leonadies]

@Ömer Hocam Kodlarınız çok güzel ellerinize sağlık. Ancak ben "Kayıt" Sekmesi ve A:A sütunu için bu işlemi yapmak istiyorum. Revize ettim ancak KAYIT sekmesi aktif iken çalışıyor. Nerede hata yapıyorum acaba?


Sizin Kodlarınız.

Sub M_Sil()
   
    Dim d As Object, i As Long, deg As String, k As Range

    Application.ScreenUpdating = False

    Set d = CreateObject("Scripting.Dictionary")

    For i = Cells(Rows.Count, "K").End(xlUp).Row To 2 Step -1
        deg = Cells(i, "K")
        If Not d.exists(deg) Then
            d.Add deg, Nothing
        Else
            If k Is Nothing Then
                Set k = Rows(i)
            Else
                Set k = Application.Union(k, Rows(i))
            End If
        End If
    Next i
   
    On Error Resume Next
    k.EntireRow.Delete

End Sub

Benim düzelttiğim Kısım

Sub M_Sil()
   
    Dim d As Object, i As Long, deg As String, a As Range

    Application.ScreenUpdating = False

    Set d = CreateObject("Scripting.Dictionary")

    For i = Sheets("Kayıt").Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
        deg = Sheets("Kayıt").Cells(i, "A")
        If Not d.exists(deg) Then
            d.Add deg, Nothing
        Else
            If a Is Nothing Then
                Set a = Rows(i)
            Else
                Set a = Application.Union(a, Rows(i))
            End If
        End If
    Next i
   
    On Error Resume Next
    a.EntireRow.Delete
MsgBox "OK"
End Sub

 

[Ömer]

Deneyiniz.

Sub M_Sil()
  
    Dim d As Object, i As Long, deg As String, a As Range, Sk As Worksheet

    Application.ScreenUpdating = False

    Set d = CreateObject("Scripting.Dictionary")
    Set Sk = Sheets("Kayıt")

    For i = Sk.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
        deg = Sk.Cells(i, "A")
        If Not d.exists(deg) Then
            d.Add deg, Nothing
        Else
            If a Is Nothing Then
                Set a = Sk.Rows(i)
            Else
                Set a = Application.Union(a, Sk.Rows(i))
            End If
        End If
    Next i
  
    On Error Resume Next
    a.EntireRow.Delete
MsgBox "OK"
End Sub

 

[leonadies]

Teşekkürler @Ömer hocam çalışıyor

 

[metin_0606]

Deneyiniz.

Sub M_Sil()
 
    Dim d As Object, i As Long, deg As String, a As Range, Sk As Worksheet

    Application.ScreenUpdating = False

    Set d = CreateObject("Scripting.Dictionary")
    Set Sk = Sheets("Kayıt")

    For i = Sk.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
        deg = Sk.Cells(i, "A")
        If Not d.exists(deg) Then
            d.Add deg, Nothing
        Else
            If a Is Nothing Then
                Set a = Sk.Rows(i)
            Else
                Set a = Application.Union(a, Sk.Rows(i))
            End If
        End If
    Next i
 
    On Error Resume Next
    a.EntireRow.Delete
MsgBox "OK"
End Sub

Ömer hocam bu makroyu üstteki mükerreri değilde son eklenen mükerreri silmek için nasıl revize edebiliriz

 

[Ömer]

For i = Sk.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1

yukarıdaki satırı aşağıdaki gibi değiştirip deneyiniz.

For i = 2 To Sk.Cells(Rows.Count, "A").End(xlUp).Row

.

 

[metin_0606]

Çok teşekkür ederim Ömer hocam sağolasın