Mükerrer Satır Silme

[leonadies]

Arkadaşlar Merhaba;

A:B sutununda resimdeki gibi veriler giriliyor. Şöyle bir makro gerekmekte;

Her zaman en alttaki bilgi güncel olacak şekilde üstteki mükerrer satırları sildirmek istiyorum. Makro sadece A sütununa bakarak üstteki mükerrer olanı silecek.

 

[halit3]

Kod:

Sub Sil()
Application.ScreenUpdating = False

son = Cells(Rows.Count, "A").End(3).Row

ReDim ara1(son): ReDim ara2(son): ReDim ara3(son)

For t = son To 2 Step -1
ara1(t) = Cells(t, "A")
ara2(t) = 1
ara3(t) = 2
Next

For i = son To 2 Step -1
For j = son To 2 Step -1
bulunan = Cells(j, "A")

If ara2(j) = 1 Then
If ara1(i) = bulunan Then
say = say + 1
If say > 1 Then
ara2(j) = 0
ara3(j) = 0
End If
End If
End If

Next j
say = 0
Next i


For k = son To 2 Step -1
If ara3(k) = 0 Then
Rows(k).Delete Shift:=xlUp
End If
Next

Application.ScreenUpdating = True
MsgBox "işlem tamam"
End Sub

 

[leonadies]

Harika. Çok teşekkürler üstadım

 

[Muzaffer Ali]

Merhaba.
Sayfa adını sağ tıklatıp "Kod Görüntüle" seçin. Açılan sayfaya aşağıdaki kodları kopyalayın.
B Kolonuna bir değer girip Entere basınca kodlar otomatik çalışır.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Aranan As String
    Dim Bulunan As Range
    If Not Intersect(Target, Range("B:B")) Is Nothing And Not Cells(Target.Row, "A") = "" And Not Cells(Target.Row, "B") = "" Then
        Aranan = Cells(Target.Row, "A")
        Set Bulunan = Range("A1:A" & Target.Row - 1).Find(What:=Aranan, LookAt:=xlWhole)
        If Not Bulunan Is Nothing Then
            Range("A" & Bulunan.Row & ":B" & Bulunan.Row).Delete xlUp
        End If
    End If
End Sub

Edit: Yeni mesajları görmemişim ama alternatif olsun.

 

[leonadies]

Teşekkür ederim. Diğer arkdaşlara da faydalı olması dileğiyle