eşleşen satırları silmek

[igultekin2000]

iyi günler; benzer soruları soruyormuş gibi oluyor, ama bir işlemde kullandığım makroyu başka çalışmada kullanmaya kalkınca, ya ilave gerekiyor yada farklı bir revize, bu çalışmamda D vade sütunu, E Giriş, F Çıkış sütunu, yapmak istediğim vadeleri eşit giriş ve çıkışların bulunduğu satırları silmek. uygulamaya çalıştığım makro şu şekildedir ;
Teşekkürler.

Sub satirsil()
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
son = Cells(Rows.Count, 1).End(3).Row
Columns("K:L").Insert Shift:=xlToRight
    For s = 2 To son
        If Cells(s, "E") > 0 Then Cells(s, "K") = Cells(s, "D") & Cells(s, "E")
        If Cells(s, "F") > 0 Then Cells(s, "K") = Cells(s, "D") & Cells(s, "F")
    Next
    With Range("L2:L" & son)
        .Formula = "=COUNTIF($K$2:$K$" & son & ",K2)": .Value = .Value
    End With
    For sat = son To 2 Step -1
        If WorksheetFunction.IsEven(Cells(sat, "L").Value) = True Then Rows(sat).Delete Shift:=xlUp
    Next
     Columns("K:L").Delete Shift:=xlToLeft
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İŞLEM TAMAMLANDI"


End Sub
Sub Bosluk_Tmz()
' özel indirim işlemi için
 On Error Resume Next
son = Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
    Cells.Replace Chr(160), ""
    For Each huc In ActiveSheet.Range("E2:F" & son) 'UsedRange
        huc.Select
        huc.Value = Trim(huc.Value)
    Next
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
End Sub

Sub sayicevir()
 'özel işlem menüsü
    Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
    NoA = Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
    For i = 2 To NoA
        Range("E" & i) = Range("F" & i) + 0
    Next
    Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic

End Sub
Sub sayicevir1()
 'özel işlem menüsü
    Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
    NoA = Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
    For i = 2 To NoA
        Range("F" & i) = Range("G" & i) + 0
    Next
    Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic

End Sub
Sub tekmakro()
Bosluk_Tmz
sayicevir
sayicevir1
End Sub
 

 

Private Sub CommandButton1_Click()
tekmakro
satirsil
End Sub

 

[igultekin2000]

Örnek listeyi eklemeyi unutmuşum