وعليكم السلام أخي العزيز أبو يوسف
بفرض أنك ستضع حالة الفيد في الخلية K2 في ورقة الهدف .. جرب الكود التالي عله يفي بالغرض

Sub Grab_Class_List()
    Dim ws As Worksheet, sh As Worksheet, s1 As String, s2 As String
    Dim i As Long, j As Long, p As Long, n As Long, arr, temp

    Set ws = ThisWorkbook.Worksheets(1)
    Set sh = ThisWorkbook.Worksheets(2)

    sh.Range("B6:I35").ClearContents
    s1 = sh.Range("K1").Value: s2 = sh.Range("K2").Value
    arr = ws.Range("B10:G" & ws.Range("B" & Rows.Count).End(xlUp).Row).Value
    ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2) + 1)

    For i = 1 To UBound(arr, 1)
        If arr(i, 3) = s1 And arr(i, 6) = s2 Then
            p = p + 1
            For j = 1 To UBound(arr, 2)
                temp(p, j) = arr(i, j)
            Next j
            temp(p, j) = p
        End If
    Next i

    On Error Resume Next
        n = WorksheetFunction.Round(p / 2, 0)
        sh.Range("B6").Resize(n, 4).Value = Application.Index(temp, Evaluate("ROW(1:" & n & ")"), Array(j, 1, 5, 6))
        sh.Range("F6").Resize(n, 4).Value = Application.Index(temp, Evaluate("ROW(" & n + 1 & ":" & p + 1 & ")"), Array(j, 1, 5, 6))
    On Error GoTo 0
End Sub

المشاركة الأصلية كتبت بواسطة: YasserKhalil وعليكم السلام أخي العزيز أبو يوسف
بفرض أنك ستضع حالة الفيد في الخلية K2 في ورقة الهدف .. جرب الكود التالي عله يفي بالغرض

CODE

Sub Grab_Class_List()
    Dim ws As Worksheet, sh As Worksheet, s1 As String, s2 As String
    Dim i As Long, j As Long, p As Long, n As Long, arr, temp

    Set ws = ThisWorkbook.Worksheets(1)
    Set sh = ThisWorkbook.Worksheets(2)

    sh.Range("B6:I35").ClearContents
    s1 = sh.Range("K1").Value: s2 = sh.Range("K2").Value
    arr = ws.Range("B10:G" & ws.Range("B" & Rows.Count).End(xlUp).Row).Value
    ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2) + 1)

    For i = 1 To UBound(arr, 1)
        If arr(i, 3) = s1 And arr(i, 6) = s2 Then
            p = p + 1
            For j = 1 To UBound(arr, 2)
                temp(p, j) = arr(i, j)
            Next j
            temp(p, j) = p
        End If
    Next i

    On Error Resume Next
        n = WorksheetFunction.Round(p / 2, 0)
        sh.Range("B6").Resize(n, 4).Value = Application.Index(temp, Evaluate("ROW(1:" & n & ")"), Array(j, 1, 5, 6))
        sh.Range("F6").Resize(n, 4).Value = Application.Index(temp, Evaluate("ROW(" & n + 1 & ":" & p + 1 & ")"), Array(j, 1, 5, 6))
    On Error GoTo 0
End Sub

روعة روعة حمد الله بالسلامة يا حبيبي وألف سلامة وربنا ما يحرمنى منك أستاذنا الغالى أبو البراء دمت في خير وفي خدمة الزملاء

رائع استاذ ياسر
جزاك الله كل خير وجعله الله فى ميزان حسناتك

بارك الله فيك أخي العزيز أبو يوسف ومشكور على كلماتك الطيبة
بارك الله فيك أخي العزيز علي ومشكور على تفاعلك الدائم بالمنتدى

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

بارك الله فيك