ترحيل ناجحين وراسبين بشروط

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

Option Explicit





Sub Salim_filter()

  Dim D As Worksheet, N As Worksheet

  Dim R As Worksheet

  Dim lrAD, arr(), i%

  Dim RgAD As Range

  Dim all_range As Range

Application.ScreenUpdating = False

arr = Array(1, 2, 3, 30)

 Set D = Sheets("dataa"): Set N = Sheets("nageh")

 Set R = Sheets("raseb")

  N.Range("A6").CurrentRegion.Clear

  R.Range("A6").CurrentRegion.Clear

 lrAD = D.Cells(Rows.Count, "ad").End(3).Row

 Set RgAD = D.Range("AD6:AD" & lrAD)

 Set all_range = D.Range("A6:AD" & lrAD)

 RgAD.AutoFilter 1, Criteria1:="*درجة*", _

 Operator:=xlOr, Criteria2:="*ناجــح*"

For i = 0 To 3

  all_range.Columns(arr(i)).SpecialCells(xlCellTypeVisible).Copy

  N.Range("A6").Offset(, i).PasteSpecial

Next

'+++++++++++++++++++++++++++++++++++

 RgAD.AutoFilter 1, Criteria1:="*راسب*", _

   Operator:=xlOr, Criteria2:="*غائب*"

 For i = 0 To 3

   all_range.Columns(arr(i)).SpecialCells(xlCellTypeVisible).Copy

   R.Range("A6").Offset(, i).PasteSpecial

 Next

D.Select

If D.AutoFilterMode Then RgAD.AutoFilter

 Application.ScreenUpdating = True



End Sub