اريد التعديل على ملف توزيع طلبة حسب الرغبات للاخ هشام كمال احمد الشريف

[اشرف النعاس]

اريد ان اغير في برمجة الملف للاخ  هشام كمال احمد الشريف حتى استطيع استخدام نفس الملف و لكن في اوجود 12 رغبة بدلا من 4 

و شكرااا 

 

Pupils Distribution According To Marks & Wishes.rar

[ياسر خليل أبو البراء]

أخي الكريم أشرف إليك الملف التالي

عله يفي بالغرض

 

Pupils Distribution According To Marks & Wishes.rar

[ياسر خليل أبو البراء]

أخي الكريم أشرف .. وهشام كمال

الأخ الحبيب المتابع للموضوع من بدايته أخي وحبيبي علاء رسلان

إليكم إصدار أفضل من الدالة المعرفة .. وبالمثال يمكنكم التعامل مع أي بيانات إن شاء الله

Public Function Wish(RngData As Range, RngWish As Range, Start_WishColumn As Long, End_WishColumn, MarkColumn As Long)
    Dim ArrData, ArrWish, ArrOut, ArrSwap
    Dim ColCount As Long, I As Long, J As Long, K As Long

    ArrData = RngData.Value
    ArrWish = RngWish.Value
    
    For I = 1 To UBound(ArrWish, 1)
        ArrWish(I, 2) = ArrWish(I, 2)
    Next I

    ReDim ArrOut(1 To UBound(ArrData, 1), 1 To 1)
    ColCount = UBound(ArrData, 2)
    ReDim ArrSwap(1 To 1, 1 To ColCount)


    For I = 1 To (UBound(ArrData, 1) - 1)
        For K = I To UBound(ArrData, 1)
            If ArrData(K, MarkColumn) > ArrData(I, MarkColumn) Then
                For J = 1 To ColCount
                    ArrSwap(1, J) = ArrData(I, J)
                    ArrData(I, J) = ArrData(K, J)
                    ArrData(K, J) = ArrSwap(1, J)
                Next J
            End If
        Next K
    Next I

    For I = 1 To UBound(ArrData, 1)
        For J = Start_WishColumn To End_WishColumn
            If ArrOut(I, 1) = "" Then
                For K = 1 To UBound(ArrWish, 1)
                    If ArrData(I, J) = ArrWish(K, 1) Then
                        If ArrWish(K, 2) > 0 Then
                            ArrOut(I, 1) = ArrWish(K, 1)
                            ArrWish(K, 2) = ArrWish(K, 2) - 1
                        End If
                    End If
                Next K
            End If
        Next J
    Next I

    For I = 1 To (UBound(ArrData, 1) - 1)
        For K = I To UBound(ArrData, 1)
            If ArrData(K, 1) < ArrData(I, 1) Then
                ArrSwap(1, 1) = ArrData(I, 1): ArrSwap(1, 2) = ArrOut(I, 1)
                ArrData(I, 1) = ArrData(K, 1): ArrOut(I, 1) = ArrOut(K, 1)
                ArrData(K, 1) = ArrSwap(1, 1): ArrOut(K, 1) = ArrSwap(1, 2)
            End If
        Next K
    Next I

    Wish = ArrOut
End Function

يتم تحديد النطاق الذي تريد النتائج به S8:S27

ثم في شريط المعادلات ضع المعادلة التالية

=Wish(D8:R27,U12:V23,3,14,15)

ثم اضغط على Ctrl + Shift + Enter

 

البارامترات الخاصة بالمعادلة :

البارامتر الأول : نطاق البيانات بالكامل D8:R27

البارامتر الثاني : نطاق الرغبات والذي يحتوي على الرغبات والحد الأقصى المسموح به

البارامتر الثالث: عمود بداية الرغبات وهو في المثال العمود رقم 3 والعد يبدأ من بداية نطاق البيانات .. أي أن العد في المثال يبدأ من العمود D

البارامتر الرابع: عمود نهاية الرغبات وهو في المثال العمود رقم 14 وكما أخبرنا العد يبدأ من بداية نطاق البيانات

البارامتر الخامس والأخير: هو رقم عمود المجموع وهو في المثال رقم 15 وكما أخبرنا ونؤكد أن العد من بداية نطاق البيانات

 

لا تنسونا من صالح دعائكم

Pupils Distribution According To Marks & Wishes V2.rar

[اشرف النعاس]

اولا بارك الله فيك على المجهود الاكتر من رائع ....لدي طلب اخير و هو اريد منك التعديل عالى المف الاخير بحيت في حالة كان ( م. الترتيب اقل من 10 ) لايتم التوجيه 
و بارك الله فيك اخي ..... شكراااا 

[ياسر خليل أبو البراء]

وضح بملف مرفق حيث أنني لم أفهم مقصودك أخي الكريم اشرف

[اشرف النعاس]

قمت برفع الملف اخي ياسر 

Pupils Distribution According To Marks & Wishees V2.rar

[ياسر خليل أبو البراء]

تفضل أخي الكريم اشرف التعديل الأخير

Public Function Wish(RngData As Range, RngWish As Range, Start_WishColumn As Long, End_WishColumn, MarkColumn As Long, MinimumMark As Single)
'البارامتر الأول يمثل نطاق البيانات بالكامل
'البارامتر الثاني يمثل نطاق الرغبات والحد الأقصى المسموح به
'البارامتر الثالث يمثل رقم عمود بداية الرغبات ضمن النطاق
'البارامتر الرابع يمثل رقم عمود نهاية الرغبات ضمن النطاق
'البارامتر الخامس يمثل رقم عمود الدرجات ضمن النطاق
'البارامتر السادس يمثل الدرجة الصغرى والناتج يكون بدون توجيه
'=Wish(D8:R27,U12:V23,3,14,15,10)
'-----------------------------------------------------------
    Dim ArrData, ArrWish, ArrOut, ArrSwap
    Dim ColCount As Long, I As Long, J As Long, K As Long

    ArrData = RngData.Value

    ArrWish = RngWish.Value
    For I = 1 To UBound(ArrWish, 1)
        ArrWish(I, 2) = ArrWish(I, 2)
    Next I

    ReDim ArrOut(1 To UBound(ArrData, 1), 1 To 1)
    ColCount = UBound(ArrData, 2)
    ReDim ArrSwap(1 To 1, 1 To ColCount)

    For I = 1 To (UBound(ArrData, 1) - 1)
        For K = I To UBound(ArrData, 1)
            If ArrData(K, MarkColumn) > ArrData(I, MarkColumn) Then
                For J = 1 To ColCount
                    ArrSwap(1, J) = ArrData(I, J)
                    ArrData(I, J) = ArrData(K, J)
                    ArrData(K, J) = ArrSwap(1, J)
                Next J
            End If
        Next K
    Next I

    For I = 1 To UBound(ArrData, 1)
        If ArrData(I, MarkColumn) < MinimumMark Then
           ArrOut(I, 1) = "بدون توجيه"
        Else
           For J = Start_WishColumn To End_WishColumn
               If ArrOut(I, 1) = "" Then
                   For K = 1 To UBound(ArrWish, 1)
                       If ArrData(I, J) = ArrWish(K, 1) Then
                           If ArrWish(K, 2) > 0 Then
                               ArrOut(I, 1) = ArrWish(K, 1)
                               ArrWish(K, 2) = ArrWish(K, 2) - 1
                           End If
                       End If
                   Next K
               End If
           Next J
        End If
    Next I

    For I = 1 To (UBound(ArrData, 1) - 1)
        For K = I To UBound(ArrData, 1)
            If ArrData(K, 1) < ArrData(I, 1) Then
                ArrSwap(1, 1) = ArrData(I, 1): ArrSwap(1, 2) = ArrOut(I, 1)
                ArrData(I, 1) = ArrData(K, 1): ArrOut(I, 1) = ArrOut(K, 1)
                ArrData(K, 1) = ArrSwap(1, 1): ArrOut(K, 1) = ArrSwap(1, 2)
            End If
        Next K
    Next I

    Wish = ArrOut
End Function

[اشرف النعاس]

مشكور جدااا اخي ياسر مجهود اكتر من رائع بارك الله فيك تمت الافادة الحمد لله 

 

 

تم تعديل يوليو 20, 2015 بواسطه اشرف النعاس

[ياسر خليل أبو البراء]

الحمد لله الذي بنعمته تتم الصالحات

الحمد لله أن تم المطلوب على خير

تقبل الله منا ومنكم

 

يرجى الضغط عىل كلمة "أعجبني هذا" في المشاركة التي أعجبتك ...

تقبل تحياتي

[mohammed mahmod]

بارك الله بكم جميعا على هذا الموضوع الممتاز...سوف احاول الاستفاده منه.. لكن يا ريت كان البرنامج اكسيس