Soru Satır silindiğinde kod çalışmaması

[mybluecat]

İyi günler ,

Ekteki dosyada bulunan "Numune Kayıt Kabul" sekmesi 24500 satırlık bir tablo içeriyor. Ben satır sayısını 2500 e düşürmek istiyorum ancak kod çalışmayı durduruyor. Acaba nasıl bir değişiklik yapılmalı kod da. Satır sayısından bağımsız çalışabilir mi ?

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Bul As Range
    Dim No As String
    Dim Bak As Long
    Dim Target_ As Range
    Application.EnableEvents = False
    For Each Target_ In Target

        If Not Intersect(Target_, Range("B6:B" & Rows.Count)) Is Nothing Then
            If Target_.Text = "" Then
                Range("C" & Target_.Row & ":AW" & Target_.Row).ClearContents
            Else
                
                Set Bul = Worksheets("ANALİZLER").Range("B:B").Find(Target_.Text, LookAt:=xlWhole)
                If Bul Is Nothing Then
                    Range("C" & Target_.Row & ":AT" & Target_.Row) = "BULUNAMADI"
                Else
                    Cells(Target_.Row, "C") = Date
                    Cells(Target_.Row, "E") = Time
                    No = 1
                    For Bak = 7 To Cells(Rows.Count, "C").End(xlUp).Row
                        If Month(Cells(Bak, "C")) = Month(Cells(Bak - 1, "C")) Then
                            No = 1 + No
                        Else
                            No = 1
                        End If
                    Next
                    No = Right("000" & No, 4)
                    No = Format(Date, "yy") & Format(Date, "MM") & Format(Date, "dd") & No
                    Cells(Target_.Row, "F") = No
                    Worksheets("ANALİZLER").Range("F" & Bul.Row & ":AT" & Bul.Row).Copy Cells(Target_.Row, "G")
                End If
            End If
        End If
    Next
    Application.EnableEvents = True
End Sub

teşekkür ederim....