Mükerrer Kayıt Silme

[baykan_m]

Merhaba Arkadaşlar,

Ekteki dosyada B sütunundaki tarih listesinde aynı tarihleri bulmasını ve son girilmiş aynı tarih harici diğer aynı kayıtları silmesini istiyorum. Mesela ekli dosyada B sütununda 01.08.2017 tarihinden 4 adet var. En son girilmiş 01.08.2017 değeri B7 hücresinde ve ben en son yazılmış olan bu değerin (B7) kalmasını, B4 : D6 arasındaki diğer aynı değerlerin silinmesini istiyorum. Aynı şekilde bu B sütununda ne kadar böyle kayıt varsa hepsinde aynısını yapmasını istiyorum. Bu konuyla alakalı baya makro çalıştım ancak Gelişmiş filtreleme tüm kayıtları siliyor. Ancak belirttiğim şekilde son kaydı bırakıp diğerlerini silebilecek birşey bulamadım. Yardımcı olan arkadaşlara şimdiden çok teşekkür ederim.

İyi çalışmalar

http://s6.dosya.tc/server10/ulxj61/SABLON.rar.html

 

[tahsinanarat]

Dosyanız ekte

Bu kodu deneyiniz

Sub sil()
son = [b65536].End(3).Row - 1

For x = 4 To son
    If WorksheetFunction.CountIf(Range("b" & x + 1 & ":b" & son), Cells(x, "b")) >= 1 Then Cells(x, "b") = ""
Next

For x = son To 4 Step -1
    If Cells(x, "b") = "" Then Rows(x).Delete
Next


End Sub

http://s6.dosya.tc/server10/6e78vi/SABLON.rar.html

 

[baykan_m]

Size ne kadar teşekkür etsem az. Tam istediğim gibi olmuş. Maaşı aldığım gibi bu siteye altın üye olmak boynumuzun borcu artık ))

 

[baykan_m]

Hocam şuan bir şeyi farkettim. Aynı kayıt yoksa yinede sondaki satırı siliyor. Aynı kayıttan hiç yoksa hiç bir işlem yapmamasını nasıl sağlarız acaba?

 

[baykan_m]

Bu konuda yardımcı olabilecek var mı arkadaşlar ?

 

[baykan_m]

Hocam şuan bir problem daha farkettim. Dosyayı ekliyorum. Dosyada bi kaç deneme yapayım dedim. Bu dosyada makroyu çalıştırdığımda 06.08.2017 tarihinden bir kaç tane olmasına rağmen hepsini sildi. Tam anlayamadım yardımcı olabilirseniz çok sevinirim

http://www.dosya.tc/server9/4giuak/SABLON1.rar.html

 

[çıtır]

Bu kodu deneyiniz.İddalı değilim istediğiniz olmayabilir.

Sub MÜKERRER_KAYITLARI_SİL()
Dim i As Byte
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 4 To Range("b65536").End(3).Row Step 1
If WorksheetFunction.CountIf(Range("B4:B" & Range("B65500").End(3).Row), Cells(i, "B")) > 1 Then
Rows(i).Delete
i=i-1
End If
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Mükerrer Kayıtlar Silinmiştir", vbInformation
End Sub

 

[halit3]

Alternatif kod

Sub satırsil()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

son = Cells(Rows.Count, "b").End(3).Row + 1

ReDim silsat(son)

For i = Cells(Rows.Count, "b").End(3).Row To 4 Step -1
aranan1 = Cells(i, 2).Value
say = 0

For r = Cells(Rows.Count, "b").End(3).Row To i Step -1
aranan2 = Cells(r, 2).Value
If aranan1 = aranan2 Then
say = say + 1
If say > 1 Then
'Cells(r, 6).Value = Cells(r, 2).Value
silsat(r) = 1
End If
End If
Next r
Next i

For i = Cells(Rows.Count, "b").End(3).Row To 4 Step -1
If Val(silsat(i)) > 0 Then
Rows(i).Delete 'Shift:=xlUp

'Range("B" & i & ":D" & i).ClearContents
'Range("B" & i & ":D" & i).Delete Shift:=xlUp

End If
Next

MsgBox "Silme İşleml Tamanlanmıştır"

End Sub

 

[Korhan Ayhan]

Bir alternatifte benden olsun..

Option Explicit

Sub Mukerrer_Kayitlari_Sil()
    Dim Alan As Range, Say As Long, X As Long, Son As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Son = Cells(Rows.Count, 2).End(3).Row
    Range("B:B").Interior.ColorIndex = False
    
    For X = 4 To Son
        If WorksheetFunction.CountIf(Range("B" & X & ":B" & Son), Cells(X, 2)) > 1 Then
            If Alan Is Nothing Then
                Set Alan = Cells(X, 2)
            Else
                Set Alan = Application.Union(Alan, Cells(X, 2))
            End If
        End If
    Next
    
    If Not Alan Is Nothing Then
        Alan.EntireRow.Delete
        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic
        MsgBox "Silme işlemi tamamlanmıştır.", vbInformation
    Else
        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic
        MsgBox "Silinecek kayıt bulunamadı!", vbExclamation
    End If
End Sub