فرز حسب الجنس بشروط

[bachiri401]

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

اريد عمل فرز مخصص حسب الجنس (ذكر/انثى) لكن لا اريد الذكور وحدهم والاناث وحدهم اريد ان يكون في الترتيب (ذكرين ثم انثيين ) 2 ذكر ثم 2 انثى حتى النهاية وفي الاخير اذا بقى عدد كبير لاحد الجنسين يبقى في الاخير وشكرا وبارك الله فيكم

فرز حسب الجنس بشروط.xlsx

[أبومروان]

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

اتفضل لعله المطلوب 

Sub CustomSortByGender()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim maleList As Collection, femaleList As Collection
    Dim i As Long, rowIndex As Long
    Dim gender As String
    Dim maleRow As Long, femaleRow As Long
    
    ' تحديد الورقة النشطة (تأكد من تعديل الاسم إذا لزم الأمر)
    Set ws = ThisWorkbook.Sheets("Sheet1") ' تأكد من أن اسم الورقة صحيح
    
    ' تحديد آخر صف في العمود A (الذي يحتوي على بيانات)
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' إنشاء مجموعات لتخزين الذكور والإناث
    Set maleList = New Collection
    Set femaleList = New Collection
    
    ' تصنيف البيانات في العمود F إلى مجموعات الذكور والإناث
    For i = 2 To lastRow ' بدءًا من F2
        gender = ws.Cells(i, "F").Value
        If gender = "ذكر" Then
            maleList.Add i ' إضافة رقم الصف إلى قائمة الذكور
        ElseIf gender = "أنثى" Then
            femaleList.Add i ' إضافة رقم الصف إلى قائمة الإناث
        End If
    Next i
    
    ' إعادة ترتيب البيانات في العمود F حسب التكرار المطلوب
    rowIndex = 2 ' نبدأ من F2
    Do While maleList.Count > 0 Or femaleList.Count > 0
        ' إضافة 2 ذكر
        If maleList.Count >= 2 Then
            maleRow = maleList(1)
            ws.Rows(maleRow).Copy
            ws.Rows(rowIndex).PasteSpecial Paste:=xlPasteAll
            maleList.Remove 1
            maleList.Remove 1
            rowIndex = rowIndex + 1
            
            maleRow = maleList(1)
            ws.Rows(maleRow).Copy
            ws.Rows(rowIndex).PasteSpecial Paste:=xlPasteAll
            maleList.Remove 1
            rowIndex = rowIndex + 1
        ElseIf maleList.Count = 1 Then
            maleRow = maleList(1)
            ws.Rows(maleRow).Copy
            ws.Rows(rowIndex).PasteSpecial Paste:=xlPasteAll
            maleList.Remove 1
            rowIndex = rowIndex + 1
        End If
        
        ' إضافة 2 أنثى
        If femaleList.Count >= 2 Then
            femaleRow = femaleList(1)
            ws.Rows(femaleRow).Copy
            ws.Rows(rowIndex).PasteSpecial Paste:=xlPasteAll
            femaleList.Remove 1
            femaleList.Remove 1
            rowIndex = rowIndex + 1
            
            femaleRow = femaleList(1)
            ws.Rows(femaleRow).Copy
            ws.Rows(rowIndex).PasteSpecial Paste:=xlPasteAll
            femaleList.Remove 1
            rowIndex = rowIndex + 1
        ElseIf femaleList.Count = 1 Then
            femaleRow = femaleList(1)
            ws.Rows(femaleRow).Copy
            ws.Rows(rowIndex).PasteSpecial Paste:=xlPasteAll
            femaleList.Remove 1
            rowIndex = rowIndex + 1
        End If
    Loop
End Sub

فرز حسب الجنس بشروط.xlsm

فرز حسب الجنس بشروط.xlsm

[عبدالله بشير عبدالله]

السلام عليكم 

بعد اذن استالذنا أبومروان حل بواسطة المصقوفات

الكود

Sub ذكرين_انثيين()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim dataArray As Variant
    Dim males() As Variant
    Dim females() As Variant
    Dim resultArray() As Variant
    Dim maleCount As Long, femaleCount As Long
    Dim rowIndex As Long, i As Long, j As Long
    
    Set ws = ThisWorkbook.Sheets("ورقة1")
    
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    
    dataArray = ws.Range("A2:F" & lastRow).Value
    
    ReDim males(1 To UBound(dataArray, 1), 1 To UBound(dataArray, 2))
    ReDim females(1 To UBound(dataArray, 1), 1 To UBound(dataArray, 2))
    
    maleCount = 0
    femaleCount = 0
    
    For i = 1 To UBound(dataArray, 1)
        If dataArray(i, 6) = "ذكر" Then
            maleCount = maleCount + 1
            For j = 1 To UBound(dataArray, 2)
                males(maleCount, j) = dataArray(i, j)
            Next j
        ElseIf dataArray(i, 6) = "انثى" Then
            femaleCount = femaleCount + 1
            For j = 1 To UBound(dataArray, 2)
                females(femaleCount, j) = dataArray(i, j)
            Next j
        End If
    Next i
    
    ReDim resultArray(1 To maleCount + femaleCount, 1 To UBound(dataArray, 2))
    rowIndex = 1
    
    i = 1
    j = 1
    Do While i <= maleCount Or j <= femaleCount
        For k = 1 To 2
            If i <= maleCount Then
                For col = 1 To UBound(dataArray, 2)
                    resultArray(rowIndex, col) = males(i, col)
                Next col
                rowIndex = rowIndex + 1
                i = i + 1
            End If
        Next k
        
        For k = 1 To 2
            If j <= femaleCount Then
                For col = 1 To UBound(dataArray, 2)
                    resultArray(rowIndex, col) = females(j, col)
                Next col
                rowIndex = rowIndex + 1
                j = j + 1
            End If
        Next k
    Loop
    
    For i = 1 To UBound(resultArray, 1)
        resultArray(i, 1) = i ' الترقيم يبدأ من 1
    Next i
    
    ws.Range("A2:F" & lastRow).ClearContents
    ws.Range("A2").Resize(UBound(resultArray, 1), UBound(resultArray, 2)).Value = resultArray
    
    MsgBox "تم الترتيب بنجاح !", vbInformation
End Sub

الملف 

فرز حسب الجنس بشروط.xlsb