Sub Test()
Const iRow As Long = 7, iCol As Long = 30
Dim ws As Worksheet, wsNageh As Worksheet, wsRaseb As Worksheet, lr As Long, r As Long, n1 As Long, n2 As Long
Application.ScreenUpdating = False
With ThisWorkbook
Set ws = .Worksheets("dataa")
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set wsNageh = .Worksheets("nageh")
wsNageh.Range("A" & iRow & ":AD" & Rows.Count).ClearContents
Set wsRaseb = .Worksheets("raseb")
wsRaseb.Range("A" & iRow & ":AD" & Rows.Count).ClearContents
End With
n1 = iRow: n2 = iRow
For r = iRow To lr
If InStr(ws.Cells(r, iCol).Value, "ناجــح") Or InStr(ws.Cells(r, iCol).Value, "منقـول") Then
wsNageh.Range("A" & n1).Value = n1 - iRow + 1
wsNageh.Range("B" & n1).Resize(1, iCol - 1).Value = ws.Range("B" & r).Resize(1, iCol - 1).Value
n1 = n1 + 1
ElseIf InStr(ws.Cells(r, iCol).Value, "راسب") Or InStr(ws.Cells(r, iCol).Value, "غائب") Then
wsRaseb.Range("A" & n2).Value = n2 - iRow + 1
wsRaseb.Range("B" & n2).Resize(1, iCol - 1).Value = ws.Range("B" & r).Resize(1, iCol - 1).Value
n2 = n2 + 1
End If
Next r
Application.ScreenUpdating = True
MsgBox "Done", 64, "YasserKhalil Excel-Egy"
End Sub