المطلوب كود ترحيل بنون ناجحون في ورقة وترحيل بنات ناحجات في ورقة اخرى

[محمد زيدان2024]

المطلوب كود ترحيل  بنون ناجحون في ورقة وترحيل بنات ناحجات في ورقة اخرى من ورقة اجمالي 4

ترحيل بنون ناجحون وترحيل بنات ناجحات.rar

[محمد زيدان2024]

@عبدالله بشير عبدالله  ممكن حل

[محمد زيدان2024]

@محمد هشام. ارجو الحل

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته 

Public Sub FilterAndCopy()
    Dim OnRng As Range, n As Long, tmp As Long
    Dim WS As Worksheet: Set WS = Sheets("اجمالي4")
    Dim Sh1 As Worksheet: Set Sh1 = Sheets("بنون ناجحون")
    Dim Sh2 As Worksheet: Set Sh2 = Sheets("بنات ناجحون")
    
    tmp = 56
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Sh1.Range("A7:BD" & Sh1.Rows.Count).Clear
    Sh2.Range("A7:BD" & Sh2.Rows.Count).Clear

    With WS
        Set OnRng = .Range("A2:BD" & .Cells(.Rows.Count, "A").End(xlUp).Row)
    End With

    With OnRng
        n = WorksheetFunction.CountIfs(OnRng.Columns(9), "ذكر")
        If n <> 0 Then
            .AutoFilter Field:=9, Criteria1:="ذكر"
            .Offset(1, 0).Resize(.Rows.Count - 1, tmp).Copy Sh1.Range("A7")
        End If

        n = WorksheetFunction.CountIfs(OnRng.Columns(9), "انثى")
        If n <> 0 Then
            .AutoFilter Field:=9, Criteria1:="انثى"
            .Offset(1, 0).Resize(.Rows.Count - 1, tmp).Copy Sh2.Range("A7")
        End If

        .Parent.AutoFilterMode = False
    End With

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

 

ترحيل بنون ناجحون وترحيل بنات ناجحات.rar

[محمد زيدان2024]

@محمد هشام. اخى الكريم مشكور ولكن اتصنفوا راسبين والمطلوب فصل الذكور الناحجين عن الاناث الناحجات من ورقة اجمالي 4

[خالد المصـــــــــــرى]

جرب اخي

المطلوب.rar

[محمد زيدان2024]

شكرا  اخى الكريم @خالد المصـــــــــــرى هذا المطلوب وشكرا للجميع

شكرا أخى @محمد هشام. تحياتى لك

[محمد هشام.]

اسف لقد فهمت الموضوع بشكل خاطئ

كنت أظنك أنك ترغب بترحيل الدكور في ورقة بنون ناجحون  والاناث في ورقة  بنات ناجحون

[محمد زيدان2024]

@محمد هشام. حضرتك استاذنا ولا يهمك يا غالى لسا عندى شيتات تانى مستنى ابداعك فيها اخى الكريم

[محمد هشام.]

53 دقائق مضت, محمد زيدان2024 said:

لا يهمك يا غالى لسا عندى شيتات تانى مستنى ابداعك فيها اخى الكريم

إليك الكود بعد تعديله 

Public Sub FilterAndCopy()
    Dim OnRng As Range
    Dim WS As Worksheet, Sh1 As Worksheet, Sh2 As Worksheet
    Dim tmp As Long, i As Long, n As Long, r As Long

    Set WS = Sheets("اجمالي4")
    Set Sh1 = Sheets("بنون ناجحون")
    Set Sh2 = Sheets("بنات ناجحون")
    tmp = 56
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Sh1.Range("A7:BD" & Sh1.Rows.Count).Clear
    Sh2.Range("A7:BD" & Sh2.Rows.Count).Clear

    With WS
        Set OnRng = .Range("A5:BD" & .Cells(.Rows.Count, "A").End(xlUp).Row)
    End With

    n = 7: r = 7
    For i = 1 To OnRng.Rows.Count + 1
        If InStr(1, WS.Cells(i, 55).Value, "ناجح", vbTextCompare) > 0 Then
            If WS.Cells(i, 9).Value = "ذكر" Then
                WS.Range("A" & i & ":BD" & i).Copy Destination:=Sh1.Range("A" & n)
                n = n + 1
            ElseIf WS.Cells(i, 9).Value = "انثى" Then
                WS.Range("A" & i & ":BD" & i).Copy Destination:=Sh2.Range("A" & r)
                r = r + 1
            End If
        End If
    Next i

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

 

ترحيل بنون ناجحون وترحيل بنات ناجحات.rar