أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
هانى على ali mohamed ali-- لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة منع ادخال البيانات بعدة شروط اكسيل اسئله واجابات


أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





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

السلام عليكم و رحمة الله و بركاته لدي قائمتين اسميتين كل قائمة تحوي ثلاثة أعمدة الاسم و اللقب الجنس (ذكر/أنثى) القسم ال ..


موضوع مغلق

الصفحة 1 من 2 < 1 2 > الأخيرة »


02-07-2021 05:14 مساء
chardoneret
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 16-05-2019
رقم العضوية : 13015
المشاركات : 41
الجنس : ذكر
تاريخ الميلاد : 5-11-1977
يتابعهم : 4
يتابعونه : 0
قوة السمعة : 59
 offline 

السلام عليكم و رحمة الله و بركاته
لدي قائمتين اسميتين 
كل قائمة تحوي ثلاثة أعمدة
الاسم و اللقب
الجنس (ذكر/أنثى)
القسم
السؤال :
كيف ادمج القائمتين في قائمة واحدة
حيث يكون الترتيب حسب الجنس و القسم لكن بالتناوب
مثلا:
الاسم   الجنس   القسم
احمد      ذكر      1ع1
اسماء      انثى    1ع2
علي         ذكر     1ع1
مريم        انثى    1ع2
......
و هكذا دواليك ...
 


أفضل إجابة مقدمة من YasserKhalil وهي:
تفضل الكود التالي .. قد لا يكون الحل هو الحل المثالي
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
عرض الإجابة




03-07-2021 05:11 صباحا
مشاهدة مشاركة منفردة [1]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10444
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36522
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif ترتيب ذكر / أنثى بالتناوب
وعليكم السلام أخي الكريم
يفضل أن يتم إرفاق ملف لكي لا يحدث لبس في الموضوع.
عموماً جرب الكود التالي وعدل على الكود يما يتناسب مع ملفك 
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
 
 
  Test File.xlsm   تحميل xlsm مرات التحميل :(7)
الحجم :(18.523) KB


03-07-2021 03:33 مساء
مشاهدة مشاركة منفردة [2]
chardoneret
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 16-05-2019
رقم العضوية : 13015
المشاركات : 41
الجنس : ذكر
تاريخ الميلاد : 5-11-1977
يتابعهم : 4
يتابعونه : 0
قوة السمعة : 59
 offline 
look/images/icons/i1.gif ترتيب ذكر / أنثى بالتناوب
شكرا اخي ياسر على الرد السريع لكن هناك اشكال
ماذا لو كانت القائمتين تحوي كلتا الجنسين و بأعداد مختلفة و غير متساوية
اليك مثال في المرفقات يوصح ذلك لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
  Test File1.zip   تحميل zip مرات التحميل :(6)
الحجم :(16.777) KB


03-07-2021 05:12 مساء
مشاهدة مشاركة منفردة [3]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10444
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36522
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif ترتيب ذكر / أنثى بالتناوب
وضعت في ردك الأخير ملف به بعض البيانات ولم تضع شكل النتائج المتوقعة لمثل هذا المثال.

03-07-2021 05:28 مساء
مشاهدة مشاركة منفردة [4]
chardoneret
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 16-05-2019
رقم العضوية : 13015
المشاركات : 41
الجنس : ذكر
تاريخ الميلاد : 5-11-1977
يتابعهم : 4
يتابعونه : 0
قوة السمعة : 59
 offline 
look/images/icons/i1.gif ترتيب ذكر / أنثى بالتناوب
اريدها 
انثى قسم١
ذكر قسم ٥
لا يهم بأيهما يبدأ
واذا بقي احد الجنسين في كلتا القائمتين يوزعه بالتناوب حسب القسم
ارجو ان أكون قد وفقت في الشرح
لان النت عندي مش ولا بد

03-07-2021 07:06 مساء
مشاهدة مشاركة منفردة [5]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10444
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36522
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif ترتيب ذكر / أنثى بالتناوب
تفضل الكود التالي .. قد لا يكون الحل هو الحل المثالي
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

03-07-2021 11:12 مساء
مشاهدة مشاركة منفردة [6]
chardoneret
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 16-05-2019
رقم العضوية : 13015
المشاركات : 41
الجنس : ذكر
تاريخ الميلاد : 5-11-1977
يتابعهم : 4
يتابعونه : 0
قوة السمعة : 59
 offline 
look/images/icons/i1.gif ترتيب ذكر / أنثى بالتناوب
بارك الله فيك و في علمك و رزقك من حيث لا تحتسب. و زادك نورا على نور


الصفحة 1 من 2 < 1 2 > الأخيرة »


الكلمات الدلالية
ترتيب ، أنثى ، بالتناوب ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 07:43 صباحا