Soru Koşula bağlı Satır Silme

[martineden-30@hotmail.com]

Merhaba arkadaşlar
Aşağıdaki kodla koşula uyan satırları silmek istiyorum.
Ekders ve Puantaj2 adında sayfalarım var. Ekders Sayfasında Butona basıldığında, veriler Puantaj2 sayfasına aktarılıyor.
Ekders Sayfasının "B" sütununda "YANLIŞ" yazılan isimlerin aktarılmasını engellemem gerekiyor. Bu konuda yardımcı olursanız sevinirim.

Function vCevir2(Rng As String) As String
If Rng = 101 Then vCevir2 = "D"
If Rng = 103 Then vCevir2 = "F"
If Rng = 106 Then vCevir2 = "I"
If Rng = 122 Then vCevir2 = "K"
If Rng = 108 Then vCevir2 = "J"
If Rng = 109 Then vCevir2 = "L"
If Rng = 116 Then vCevir2 = "H"
If Rng = 117 Then vCevir2 = "G"
If Rng = 119 Then vCevir2 = "E"
If Rng = 110 Then vCevir2 = "M"
End Function

Sub Puantaj2Hesap()
Tbas = Now
Dim EkASon, EkFSon, EkSonStn, X0, X1, yPntj, zSon, mPuantaj2Son, sonSatir As Long
Dim satirKont As Integer
On Error Resume Next


EkASon = Cells(Rows.Count, 1).End(xlUp).Row '
EkFSon = Cells(Rows.Count, 10).End(xlUp).Row
EkSonStn = Cells(3, Columns.Count).End(xlToLeft).Column
mPuantaj2Son = Sheets("Puantaj2").Cells(Rows.Count, 13).End(xlUp).Row - 1
'MsgBox (mPuantaj2Son)
With Sheets("Puantaj2")
.Range("A3:L3").ClearContents
.Rows("4:" & mPuantaj2Son).Delete

'Başlık Yazdırma
.Cells(1, 1) = Worksheets("Ayar").Cells(7, 1) & Chr(10) & UCase(Replace(Replace(Format(Worksheets("Ayar").Cells(1, 1), "MMMM"), "ı", "I"), "i", "İ") & " " & "AYI EK DERS ÇİZELGESİ" & " (" & Worksheets("ayar").Cells(15, 1) & ")")
.Cells(15, 1).Value = txtBaslik2.Value
'Onaylayan bilgisi
 sonSatir = Sheets("Puantaj2").Cells(Rows.Count, 1).End(xlUp).Row 'Dolu son Satırı Bul
'Tarih Yazdır
.Range(.Cells(sonSatir + 3, 11), .Cells(sonSatir + 3, 12)).Merge 'Hücre birleştir
.Range(.Cells(sonSatir + 3, 11), .Cells(sonSatir + 3, 12)).HorizontalAlignment = xlCenter 'Birleştirilen Hücreleri Ortala
.Cells(sonSatir + 3, 11) = Date 'Birleştirilen Hücreye Tarih Bas
'Müdür YAzdır
.Range(.Cells(sonSatir + 5, 11), .Cells(sonSatir + 5, 12)).Merge 'Hücre birleştir
.Range(.Cells(sonSatir + 5, 11), .Cells(sonSatir + 5, 12)).HorizontalAlignment = xlCenter 'Birleştirilen Hücreleri Ortala
.Cells(sonSatir + 5, 11) = Worksheets("Ayar").Cells(5, 1)
'Unvan Yazdır
.Range(.Cells(sonSatir + 6, 11), .Cells(sonSatir + 6, 12)).Merge 'Hücre birleştir
.Range(.Cells(sonSatir + 6, 11), .Cells(sonSatir + 6, 12)).HorizontalAlignment = xlCenter 'Birleştirilen Hücreleri Ortala
.Cells(sonSatir + 6, 11) = Worksheets("Ayar").Cells(6, 1)



X0 = 4
X1 = 4
yPntj = 3


    Do While X1 <= EkFSon
satirKont = WorksheetFunction.CountA(.Range("A" & yPntj & ":c" & yPntj))
        If satirKont = 1 Then
        .Rows(yPntj).Insert Shift:=xlShiftDown, CopyOrigin:=0
        End If

        .Range("A" & yPntj) = Range("A" & X0)
        .Range("B" & yPntj) = Range("D" & X0)
        .Range("C" & yPntj) = Range("E" & X0)
        X1 = Range("A" & X0).End(xlDown).Row
        If X1 > EkFSon Then X1 = EkFSon + 1
        For X = X0 To X1 - 1
            stn = vCevir2(Range("l" & X).Value)
            .Range(stn & yPntj).Value = Cells(X, EkSonStn).Value
        Next
    yPntj = yPntj + 1
    X0 = X1

    Loop

zSon = .Cells(Rows.Count, 14).End(xlUp).Row '14 ==> N sütunu
.Range("N3") = "=sum(D3:M3)"
.Range("N3:N" & zSon).FillDown
.Range("D" & zSon) = "=sum(D3:D" & zSon - 1 & ")"
.Range("D" & zSon & ":M" & zSon).FillRight

.Range("A3:N" & zSon - 1).Borders.LineStyle = xlContinuous


End With

MsgBox ("Veriler Başarıyla MEB Çizelgeye aktarıldı") ' Tbit & " - " & Tbas)
 
End Sub