Koşula uyan satırları silme

[iskelet]

Selam,
Yapmak istediğim şeyi ekli dosyada belirttim.
İlgilenen arkadaşlara şimdiden teşekkürler.

 

[Korhan Ayhan]

Veri menüsünden "YİNELENENLERİ KALDIR" seçeneği işinizi görmüyor mu?

 

[iskelet]

Veri menüsünden "YİNELENENLERİ KALDIR" seçeneği işinizi görmüyor mu?

Korhan bey yinelenenleri kaldır demek aynı olan satırları kaldır demek ise işimi görmüyor maalesef ben verdiğim sayı kadar benzeyen de olsa kaldırmak istiyorum.

 

[Korhan Ayhan]

Ben sorunuzu okurken Sayfa2 olayı dikkatimden kaçmış. Bu sebeple YİNELENENLERİ KALDIR önerisinde bulunmuştum. Kusura bakmayın. Aşağıdaki kodu kullanabilirsiniz.

Sub Kosula_Gore_Satir_Sil()
    Dim S1 As Worksheet
    Dim S2 As Worksheet
    Dim X, Y, Say
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    Application.ScreenUpdating = False
    
    For X = S1.Cells(Rows.Count, 1).End(3).Row To 1 Step -1
        For Y = 1 To 13
            If WorksheetFunction.CountIf(S1.Range("A" & X & ":M" & X), S2.Cells(1, Y)) > 0 Then
                Say = Say + 1
            End If
        Next
        If Say >= S1.Range("O1") Then
            S1.Rows(X).Delete
        End If
        Say = 0
    Next
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[iskelet]

Ben sorunuzu okurken Sayfa2 olayı dikkatimden kaçmış. Bu sebeple YİNELENENLERİ KALDIR önerisinde bulunmuştum. Kusura bakmayın. Aşağıdaki kodu kullanabilirsiniz.

Sub Kosula_Gore_Satir_Sil()
    Dim S1 As Worksheet
    Dim S2 As Worksheet
    Dim X, Y, Say
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    Application.ScreenUpdating = False
    
    For X = S1.Cells(Rows.Count, 1).End(3).Row To 1 Step -1
        For Y = 1 To 13
            If WorksheetFunction.CountIf(S1.Range("A" & X & ":M" & X), S2.Cells(1, Y)) > 0 Then
                Say = Say + 1
            End If
        Next
        If Say >= S1.Range("O1") Then
            S1.Rows(X).Delete
        End If
        Say = 0
    Next
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Korhan bey çok teşekkür ederim. Ellerinize sağlık.