Duplicate(mükerrer) verileri belirli bir öncelik sırasına göre silme

[prepositions]

Arkadaşlar elimde 5 farklı kategoride datalar var. Bu dataların hepsi bir excel dökümanında mevcut. Dataları ilk sütunlarındaki yıl ibaresine göre ayırdım. Yane 2007,2006,2005,2004 ve 2003 yıllarına ilişkin şirket bilgileri var elimde.
Ekteki dosyada da göreceksiniz burada mükerrrer olan kayıtları sildirmem gerekiyor ve bu silme işleminde şirket adı kısmı aynı olan datalarda sırası ile hangisinin yılı büyükse o satırı bıraksın. Yane aynı isimli şirketler var bunların örneğin 2005,2004 ve 2003 yılları dataları mevcut. Burada 2004 ve 2003 ü silip 2005 yılı datasının bulunduğu satırı bıraksın...Örnek ekte mevcuttur. Bana yardımcı olabilirseniz çok sevinirim. Şimdiden teşekkürler....

 

[veyselemre]

Sub Test()
basla:
son = [a65536].End(3).Row
    For x = 2 To son - 1
        sirket = Left(Cells(x, 2), InStr(Cells(x, 2), " "))
        For y = x + 1 To son
        If WorksheetFunction.Proper(Cells(y, 2)) Like WorksheetFunction.Proper(sirket & "*") Then
            If Cells(x, 1) > Cells(y, 1) Then
                Rows(y).Delete
                Else
                Rows(x).Delete
            End If
        GoTo basla
        End If
        Next y
    Next x
End Sub

 

[Skorpiyon]

Sayın Veyselemre,

Arkadaşımıza cevap vermek için bende aşağıdaki kodu yazmaya çalışıyordum. Yalnız kodlarda bir hata yapıyorum.. Nerde olduğunu söyleyebilmeniz mümkün mü acaba ?

Dim a, b
For a = 2 To 100
On Error Resume Next
Cells.Find(What:=Cells(a, 2).Value, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False).Activate
For b = 3 To WorksheetFunction.CountA(Worksheets("Sheets1").Range("A2:A65535")) + 1
If ActiveCell.Value = Cells(b, 2).Value And ActiveCell.Offset(0, -1).Value > Cells(b, 1).Value Then
Cells(b, 1).Select
ActiveCell.EntireRow.Select
Selection.Delete
ElseIf ActiveCell.Value = Cells(b, 2).Value And ActiveCell.Offset(0, -1).Value < Cells(b, 1).Value Then
ActiveCell.EntireRow.Select
Selection.Delete
End If
Next b
Next a

Teşekkür ve Saygılarımla...

 

[prepositions]

Veysel emre Bey gönderdiğiniz makro için teşekkür ederim. Ancak bu scriptte bir şey daha isteyebilirmiyim? Bu scriptte için o kelimenin geçtiği bütün satırları siliyor, bire bir eşleşme ye baksa sonra çok benzere baksa ona göre silse olurmu acaba?Ekte ne demek istediğimi tekrar gönderiyorum...