Koşullu yinelenenleri kaldırma

[TURANNET]

Merhaba,
Ekte verilen örnek dosyada, "F3" sütununa (F3:F1000 aralığında) göre yinelenenleri kaldırmak istiyorum.
Ancak, burada "H" sütununda "VARİS" olan satırlar için bunu yapsın istiyorum. Hisseli (1/7, 3/56 gibi) olan satırlara dokunulmayacak.
Örnek dosyada, 57 adet satır bulunmakta, bu tarife uygun "yinenelenenleri kaldır" işlemi yapıldığında, "VARİS" li "15 "adet satır ve hisseli (1/7, 3/56 gibi) "9" adet satır kalması gerekiyor.
Teşekkürler..
örnek_dosya.xls - 52 KB

 

[ÖmerBey]

Merhaba,
Sayfanın yedeğiniz aldıktan sonra aşağıdaki kodları deneyiniz.
Not: C sütünundaki formülü =SATIR()-7 şeklinde düzenleyerek oluşan hatayı düzeltebilirsiniz.

Sub kod()
Dim sil As Range, a As Long
Set sil = Cells(Rows.Count, "F")
For a = 8 To sil.End(3).Row
    If Cells(a, "H") = "VARİS" And WorksheetFunction.CountIfs(Range("H8:H" & a), "VARİS", Range("F8:F" & a), Cells(a, "F")) > 1 Then
        Set sil = Union(sil, Cells(a, "F"))
    End If
Next
sil.EntireRow.Delete
End Sub

 

[ÖmerBey]

Kullandığınız versiyondan dolayı çalışmama ihtimaline karşılık alternatif olarak aşağıdaki kodu kullanabilirsiniz.

Sub kod1()
Dim sil As Range, a As Long, s As Object, tc As String
Set sil = Cells(Rows.Count, "F")
Set s = CreateObject("Scripting.Dictionary")
For a = 8 To sil.End(3).Row
    If Cells(a, "H") = "VARİS" Then
        tc = Cells(a, "F").Text
        If s.Exists(tc) Then
            Set sil = Union(sil, Cells(a, "F"))
        Else
            s.Add tc, 1
        End If
    End If
Next
sil.EntireRow.Delete
End Sub

 

[TURANNET]

Kullandığınız versiyondan dolayı çalışmama ihtimaline karşılık alternatif olarak aşağıdaki kodu kullanabilirsiniz.

Sub kod1()
Dim sil As Range, a As Long, s As Object, tc As String
Set sil = Cells(Rows.Count, "F")
Set s = CreateObject("Scripting.Dictionary")
For a = 8 To sil.End(3).Row
    If Cells(a, "H") = "VARİS" Then
        tc = Cells(a, "F").Text
        If s.Exists(tc) Then
            Set sil = Union(sil, Cells(a, "F"))
        Else
            s.Add tc, 1
        End If
    End If
Next
sil.EntireRow.Delete
End Sub

ÖmerBey, çok teşekkür ediyorum.
Excelin yerleşik filtreleme ve yinelenenleri kaldır özellikleri ile sonuç almam olanaksızdı.
Otomatik sıra no veren formül için de ayrıca teşekkürler.

 

[TURANNET]

Soru da belirtmeyi unutmuşum.
Bu işlemi; POSTA_LISTESİ, Sayfa 1, Sayfa 2, ....., Sayfa n 'lerden oluşan bir excel dosyasında POSTA_LISTESI hariç diğer tüm sayfalar da yapmak için kodları (son vediğiniz kodları) nasıl düzenlemeliyiz.
Tekrar teşekkürler..

 

[ÖmerBey]

Bu işlemi; Sayfa 1, Sayfa 2, ....., Sayfa n 'lerden oluşan bir excel dosyasında tüm sayfalar için yapmak için kodları nasıl düzenlemeliyiz

Hangi kodu?

 

[TURANNET]

Hangi kodu?

Sub kod1()
Dim sil As Range, a As Long, s As Object, tc As String
Set sil = Cells(Rows.Count, "F")
Set s = CreateObject("Scripting.Dictionary")
For a = 8 To sil.End(3).Row
If Cells(a, "H") = "VARİS" Then
tc = Cells(a, "F").Text
If s.Exists(tc) Then
Set sil = Union(sil, Cells(a, "F"))
Else
s.Add tc, 1
End If
End If
Next
sil.EntireRow.Delete
End Sub

 

[ÖmerBey]

Sub kod1()
Dim sil As Range, a As Long, s As Object, tc As String
Dim sh As Worksheet
Set s = CreateObject("Scripting.Dictionary")
For Each sh In Worksheets
    Set sil = sh.Cells(Rows.Count, "F")
    For a = 8 To sil.End(3).Row
        If sh.Cells(a, "H") = "VARİS" Then
            tc = sh.Cells(a, "F").Text
            If s.Exists(tc) Then
                Set sil = Union(sil, sh.Cells(a, "F"))
            Else
                s.Add tc, 1
            End If
        End If
    Next
    sil.EntireRow.Delete
    s.RemoveAll
Next
End Sub

 

[TURANNET]

Teşekkürler.