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

[محمد زيدان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]

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

[محمد هشام.]

3 ساعات مضت, محمد زيدان2024 said:

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

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

Public Sub FilterAndCopy()
    Const tmpCol As String = "BC"
    Dim OnRng As Range, i As Long, n As Long, r As Long
    Dim WS As Worksheet, Sh1 As Worksheet, Sh2 As Worksheet
    
    
    Set WS = Sheets("اجمالي4")
    Set Sh1 = Sheets("بنون ناجحون")
    Set Sh2 = Sheets("بنات ناجحون")
    
    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, tmpCol).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

تم تعديل منذ 32 دقائق بواسطه محمد هشام.