وعليكم السلام أخي الكريم
جرب الكود التالي عله يفي بالغرض إن شاء الله

Sub Test()
    Dim a, v, ws As Worksheet, sh As Worksheet, lr As Long, i As Long, k As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets(1)
        Set sh = ThisWorkbook.Worksheets(2)
        v = sh.Range("E1").Value
        If v = Empty Or Not IsNumeric(v) Then MsgBox "Enter Proper Grade First", vbExclamation: Exit Sub
        lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
        a = ws.Range("B4:C" & lr).Value
        ReDim b(1 To UBound(a), 1 To 2)
        For i = LBound(a) To UBound(a)
            If a(i, 2) = v Then
                k = k + 1
                b(k, 1) = k
                b(k, 2) = a(i, 1)
            End If
        Next i
        If k > 0 Then
            sh.Range("A7:B" & Rows.Count).ClearContents
            sh.Range("A7").Resize(k, UBound(b, 2)).Value = b
        End If
    Application.ScreenUpdating = True
End Sub

الاخ ابو البراء تحية حب وتقدير
يبدو اننى لم اوضح المطلوب
المطلوب هو ترحيل جميع الاسماء المكتوب امامها رقم الفصل يعنى كل اسم امامه في الخلية c في ورقة1 مكتوب امامه رقم 1 يتم ترحيله وهكذا اذا كتبت 2 في الخلية E1 يتم ترحيل كل الاسماء التى امامها الرقم 2 وشاكر لكم وارجو من الله ان يجزيكم خير الجزاء

اعتذر شديد الاعتذار الكود يعمل جيداً والعيب عندى انا مكنتش مركز اعتذر للجميع والفشكر استاذ ياسر وارجو المعذرة لعدم تركيزى بس اعمل ايه قلة نوم ارجو ات تسامحونى على الازعاج وجعله الله في ميزان العزيز ابو الراء

بارك الله فيك أخي الكريم والحمد لله أن تم المطلوب على خير
والحمد لله الذي بنعمته تتم الصالحات