Tekrar Eden Tüm Satırı Tespit Ederek Silmek

[uyecik]

Arkadaşlar forumda veya internette aradım ama sadece tek satır baz alınarak tespit ediliyor ve o şekilde satır siliniyor. Ama ben tüm satır aynı ise aynı olan satırın biri silinsin istiyorum. Bunu nasıl yapabilirim.
Örnek
A B C D E
1. Satır 1 2 3 4 5
2. Satır 2 2 1 3 3
3. Satır 4 3 2 4 1
4. Satır 3 2 1 3 1
5. Satır 2 2 1 3 3
Yukarıdaki örnekteki gibi olduğunda 2 ve 5. Satırdaki (2 2 1 3 3) olan satırın biri silinsin istiyorum.
Tabi bunu yinelenenler kaldır metodu ile değil de VBA kodları ile yapmak istiyorum. Mümkün müdür?

 

[çıtır]

Modül ekleyerek deneyiniz.

Sub tekkal()
Dim s1 As Worksheet
Dim i As Integer
Set s1 = Sheets("Sayfa1")
son = Cells(655336, "A").End(3).Row
For i = son To 2 Step -1

If WorksheetFunction.CountIfs(s1.Range("A2:A" & i), s1.Range("A" & i), s1.Range("B2:B" & i), s1.Range("B" & i), s1.Range("C2:C" & i), s1.Range("C" & i), s1.Range("D2:D" & i), s1.Range("D" & i), s1.Range("E2:E" & i), s1.Range("E" & i)) > 1 Then Rows(i).Delete

Next i
End Sub

 

[Ziynettin]

Verileriniz fazla ise alternatif kod.

Sub deneme()
a = Range("A2:D" & Cells(Rows.Count, 1).End(3).Row)
Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(a)
        krt = ""
        For j = 1 To UBound(a, 2)
            krt = krt & a(i, j)
        Next j
        d(krt) = i
    Next i
    ReDim b(1 To d.Count, 1 To UBound(a, 2))
    For Each v In d.keys
        say = say + 1
        For j = 1 To UBound(a, 2)
            b(say, j) = a(d(v), j)
        Next j
    Next v
    Range("A2:D" & Rows.Count).ClearContents
    [A2].Resize(say, UBound(a, 2)) = b
MsgBox "İşlem bitti.", vbInformation
End Sub

 

[uyecik]

Modül ekleyerek deneyiniz.

Sub tekkal()
Dim s1 As Worksheet
Dim i As Integer
Set s1 = Sheets("Sayfa1")
son = Cells(655336, "A").End(3).Row
For i = son To 2 Step -1

If WorksheetFunction.CountIfs(s1.Range("A2:A" & i), s1.Range("A" & i), s1.Range("B2:B" & i), s1.Range("B" & i), s1.Range("C2:C" & i), s1.Range("C" & i), s1.Range("D2:D" & i), s1.Range("D" & i), s1.Range("E2:E" & i), s1.Range("E" & i)) > 1 Then Rows(i).Delete

Next i
End Sub

Teşekkür ederim işime yaradı.

Verileriniz fazla ise alternatif kod.

Sub deneme()
a = Range("A2:D" & Cells(Rows.Count, 1).End(3).Row)
Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(a)
        krt = ""
        For j = 1 To UBound(a, 2)
            krt = krt & a(i, j)
        Next j
        d(krt) = i
    Next i
    ReDim b(1 To d.Count, 1 To UBound(a, 2))
    For Each v In d.keys
        say = say + 1
        For j = 1 To UBound(a, 2)
            b(say, j) = a(d(v), j)
        Next j
    Next v
    Range("A2:D" & Rows.Count).ClearContents
    [A2].Resize(say, UBound(a, 2)) = b
MsgBox "İşlem bitti.", vbInformation
End Sub

Çok teşekkürler sizin kisi de işime yaradı üstelik sütun sayısını çoğaltmak daha kolay oldu sizde.

Şayet müsait olur da kodların açıklamasını da bir ara yapabilirseniz çok sevinirim.

Tekrar ikinizi de teşekkür ederim, elleriniz dert görmesin.