ترتيب ذكر / أنثى بالتناوب

Sub Test()

    Const colOutput As Integer = 10

    Dim lr As Long, r As Long, k As Long

    Application.ScreenUpdating = False

        lr = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

        k = 2

        Cells(1, colOutput).CurrentRegion.Offset(1).ClearContents

        For r = 2 To lr

            Cells(k, colOutput).Resize(, 3).Value = Cells(r, 1).Resize(, 3).Value

            Cells(k + 1, colOutput).Resize(, 3).Value = Cells(r, 5).Resize(, 3).Value

            k = k + 2

        Next r

    Application.ScreenUpdating = True

End Sub

Sub Test()

    Const colOutput As Integer = 10

    Dim e, rng As Range, lr As Long, r As Long, k As Long, n As Long, m As Long, ii As Long, t As Long

    Application.ScreenUpdating = False

        n = 1: k = 2

        Columns("N:T").ClearContents

        Cells(1, colOutput).CurrentRegion.Offset(1).ClearContents

        For Each e In Array("A1", "E1")

            Set rng = Range(e).CurrentRegion.Offset(1)

            Set rng = rng.Resize(rng.Rows.Count - 1)

            lr = Cells(Rows.Count, colOutput).End(xlUp).Row + 1

            With Cells(1, Range(e).Column + 13).CurrentRegion

                .ClearContents

                .Cells(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value

                .Sort Key1:=.Cells(1, 2), Order1:=IIf(e = "A1", xlAscending, xlDescending), Header:=xlNo

            End With

        Next e

        Do Until Cells(n, colOutput + 5) = Cells(n, colOutput + 9)

            n = n + 1

        Loop

        If Cells(n, colOutput + 5) <> "" Then

            m = 1

            Do Until Cells(n, colOutput + 5) <> "" And Cells(n, colOutput + 5) <> Cells(n + m, colOutput + 5)

                m = m + 1

            Loop

            If Cells(m + n, colOutput + 5) <> "" Then

                ii = Cells(Rows.Count, colOutput + 4).End(xlUp).Row

                Range(Cells(m + n, colOutput + 4), Cells(ii, colOutput + 6)).Cut

                Cells(n, colOutput + 4).Insert Shift:=xlDown

            End If

            t = n

            n = 1

            Do Until Cells(n, colOutput + 5) = Cells(n, colOutput + 9)

                If n >= t Then

                    Cells(k + 1, colOutput).Resize(, 3).Value = Cells(n, colOutput + 4).Resize(, 3).Value

                    Cells(k, colOutput).Resize(, 3).Value = Cells(n, colOutput + 8).Resize(, 3).Value

                Else

                    Cells(k, colOutput).Resize(, 3).Value = Cells(n, colOutput + 4).Resize(, 3).Value

                    Cells(k + 1, colOutput).Resize(, 3).Value = Cells(n, colOutput + 8).Resize(, 3).Value

                End If

                k = k + 2

                n = n + 1

            Loop

            Do Until Cells(n, colOutput + 5) = "" Or Cells(n, colOutput + 9) = ""

                Cells(k, colOutput).Resize(, 3).Value = Cells(n, colOutput + 4).Resize(, 3).Value

                Cells(k + 1, colOutput).Resize(, 3).Value = Cells(n, colOutput + 8).Resize(, 3).Value

                n = n + 1

                k = k + 2

            Loop

            If Cells(n, colOutput + 5) = "" And Cells(n, colOutput + 9) <> "" Then

                ii = Cells(Rows.Count, colOutput + 8).End(xlUp).Row

                Range(Cells(n, colOutput + 8), Cells(ii, colOutput + 10)).Copy

                Cells(k, colOutput).PasteSpecial Paste:=xlPasteValues

                Application.CutCopyMode = False

            End If

            If Cells(n, colOutput + 5) <> "" And Cells(n, colOutput + 9) = "" Then

                ii = Cells(Rows.Count, colOutput + 4).End(xlUp).Row

                Range(Cells(n, colOutput + 4), Cells(ii, colOutput + 6)).Copy

                Cells(k, colOutput).PasteSpecial Paste:=xlPasteValues

                Application.CutCopyMode = False

            End If

        End If

        Columns("N:T").ClearContents

    Application.ScreenUpdating = True

End Sub