مطلوب كود ارقام عشوائية حسب المطلوب

[الرائد77]

السلام عليكم .

الاخوة الكرام الرجاء المساعدة في عمل كود حسب المطلوب في الملف المرفق .

مطلوب 2 كود حسب الورقتين في الملف

بارك الله فيكم .

مطلوب 1 و 2.xlsx

[أحمد يوسف]

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

تفضل به طلبك

تقسيم 100 نقطة على عدد طلاب اكثر او اقل من 100

قرعه ( سحب )

اختيار عشوائى اسبوعى

[سليم حاصبيا]

جرب هذا الماكرو

Option Explicit
Sub N_rand_numbers_Between(col)

    'Created by_salim 23/11/2019
   'this code distribute teachers randomly
    Dim i%, m%, x%, k%
    m = 8
    Dim minn%: minn = 1
    Dim maxx%: maxx = [d2]
    Dim arr1(), arr2()
    Dim myArrayList As Object, myArrayList2 As Object
    Dim how_many
         If Not IsNumeric([d2]) _
        Or [d2] < 1 _
        Or [d2] > maxx - minn + 1 Then
        how_many = maxx - minn + 1
      Else
        how_many = Int([d2])
      End If
    Range(col & 8, Range(col & 7).End(4)).ClearContents
   For k = 1 To 3
    Set myArrayList = CreateObject("System.Collections.ArrayList")
    For i = 1 To maxx - minn + 1
    myArrayList.Add Rnd(i)
Next
arr1() = myArrayList.toarray

    Set myArrayList2 = myArrayList.Clone
    myArrayList2.Sort
    arr2() = myArrayList2.toarray
     For i = LBound(arr2) To UBound(arr2)
     If i > how_many - 1 Then Exit For
      x = Application.Match(arr2(i), arr1, 0)
      Range(col & m) = x + minn - 1: m = m + 1
     Next
Next
    Set myArrayList = Nothing: Erase arr1
    Set myArrayList2 = Nothing: Erase arr2
End Sub
'++++++++++++++++++++++++++++++++++++++++++++++++
Sub test()
Dim arr, tt%
arr = Array("D", "E", "F", "G", "H", "I", "J", "K", "L", "M")
For tt = LBound(arr) To UBound(arr)
Call N_rand_numbers_Between(arr(tt))
Next
Erase arr
End Sub

الملف مرفق 

ضغطة  واحدة على  زر  Run يتم التبديل كل مرة

Exam 1_2.xlsm

[الرائد77]

بارك الله فيكم على الردود. عمل رائع جدا  الأخ سليم حاصبيا. جزاك الله خيرا. و بارك الله في علمك. لكن هناك مشكل بسيط. عندما اغير عدد مرات التكرار الى 4 او 2 يعمل فقط على 3 مرات. . مثلا يمكن تكون 15 قاعة و 60 استاذ .فأقوم بتوزيع كل 4 أساتذة في قاعة واحدة. أي عدد مرات التكرار تكون 4. و بارك الله فيكم .

[سليم حاصبيا]

 قم بتعديل هذا السطر في الكود

For k = 1 To 3

الى هذا

For k = 1 To [f2]

 

[سليم حاصبيا]

الكود يعمل في اي صفحة تريد اذا وضعته في موديل مستقل وليس في موديل يخص صفحة معينة

على فكرة اين الاعجاب و افضل اجابة

[الرائد77]

ارك الله فيك رائع  . ماذا عن المطلوب رقم 2. هل يمكن عمل كود له.

شكرا اخي سليم . المطلوب 2 فيه شرط آخر. الاهم بالنسبة لي هو الأول. بارك الله فيك 

[سليم حاصبيا]

تم اضافة ماكرو للعمل على صفحة   المطلوب 2     مع اضافة الاحتياط (باللون العادي) والأصليين باللون الأزرق

الماكرو للصفحة   المطلوب 2 

Option Explicit
Sub N_rand_For_matloub_2(col)
    'Created by_salim 23/11/2019
   'this code distribute teachers randomly
    Dim i%, m%, x%, k%
    Dim MY_max%, ro%, S_Rg As Range
     m = 8
    Dim minn%: minn = 1
    Dim maxx%
    Dim arr1(), arr2()
    Dim how_many
    Dim myArrayList As Object, myArrayList2 As Object
    MY_max = Cells(Rows.Count, 2).End(3).Row
      If Not IsNumeric([E2]) _
         Or [E2] < 1 Or [E2] > 18 Then
         maxx = 18
      Else
        maxx = Int([E2])
      End If
    how_many = maxx - minn + 1
    Range(col & 8, Range(col & 7).End(4)).ClearContents
    Set myArrayList = CreateObject("System.Collections.ArrayList")
    For i = 1 To maxx - minn + 1
    myArrayList.Add Rnd(i)
Next
arr1() = myArrayList.toarray
    Set myArrayList2 = myArrayList.Clone
    myArrayList2.Sort
    arr2() = myArrayList2.toarray
     For i = LBound(arr2) To UBound(arr2)
     If i > how_many - 1 Then Exit For
      x = Application.Match(arr2(i), arr1, 0)
      Range(col & m) = x + minn - 1: m = m + 1
      If m > MY_max - [f2] Then GoTo Exit_Me
     Next
Exit_Me:
   '+++++++++++++++++++++++++++++++++++
    For ro = 8 To MY_max
    Set S_Rg = Range(col & 8).Resize(maxx).Find(Cells(ro, 1), lookat:=1)
    If S_Rg Is Nothing Then Range(col & m) = "احتياط :" & Cells(ro, 1): m = m + 1
    Next
  '++++++++++++++++++++++++++++++++++
    Set myArrayList = Nothing: Erase arr1
    Set myArrayList2 = Nothing: Erase arr2
End Sub
'++++++++++++++++++++++++++++++++++++++++++++++++
Sub test_for_matloub_2()
Dim arr, tt%
arr = Array("D", "E", "F", "G", "H", "I", "J", "K", "L", "M")
For tt = LBound(arr) To UBound(arr)
Call N_rand_For_matloub_2(arr(tt))
Next
Erase arr
End Sub

الملف من جديد

 

 

Exam 1_2_new.xlsm

[الرائد77]

عمل رائع جدا جدا. 100 اعجاب و فعلا افضل اجابة بارك الله فيك

[الرائد77]

السلام عليكم . الأخ سليم حاصبيا . بالنسبة للمطلوب 2. فإنه دائما يقوم بوضع آخر الاساتذة في الاحتياط . اي نفس الاساتذة في الاحتياط في كل الفترات. هل يمكن التناوب في الاحتياط عشوائيا حسب الفترات ؟ . ملاحظة أخرى في الاحتياط مثلا عندما أختار 21 أستاذ و أنا فقط عندي 14 قاعة فإنه يكتب مثلا احتياط:21 ., و لا توجد القاعة رقم 21. المطلوب أعادة توزيع عدد الاساتذة المتبقين عشوائيا على القاعات من 1 الى 14 فقط مثلا الباقي 6 كل فترة يختار  6 من قائمة الاساتدة عشوائيا . إن أمكن فقط و لكم جزيل الشكر. 

تم تعديل نوفمبر 24, 2019 بواسطه الرائد77

[سليم حاصبيا]

ان ما تراه في صفوف الحتياط هو رقم الاستاذ وليس رقم القاعة 

للمزيد والتأكد هذا الملف من جديد مع (تعديل بسيط في الكود)  ليظهر لك اسماء الاساتذة الاحتياط

Option Explicit
Sub For_matloub_2(col)
    'Created by_salim 23/11/2019
   'this code distribute teachers randomly
    Dim i%, m%, x%, k%
    Dim MY_max%, ro%
    Dim st$
     m = 8
    Dim minn%: minn = 1
    Dim maxx%
    Dim arr1(), arr2()
    Dim how_many
    Dim myArrayList As Object, myArrayList2 As Object
    MY_max = Cells(Rows.Count, 2).End(3).Row
      If Not IsNumeric([E2]) _
         Or [E2] < 1 Or [E2] > 18 Then
         maxx = 18
      Else
        maxx = Int([E2])
      End If
    how_many = maxx - minn + 1
    Range(col & 8, Range(col & 7).End(4)).ClearContents
    Set myArrayList = CreateObject("System.Collections.ArrayList")
    For i = 1 To maxx - minn + 1
    myArrayList.Add Rnd(i)
Next
arr1() = myArrayList.toarray
    Set myArrayList2 = myArrayList.Clone
    myArrayList2.Sort
    arr2() = myArrayList2.toarray
     For i = LBound(arr2) To UBound(arr2)
     If i > how_many - 1 Then Exit For
      x = Application.Match(arr2(i), arr1, 0)
        Range(col & m) = _
        IIf(m > MY_max - [f2], "احتياط :" & Cells(x + minn + 6, 3), Cells(x + minn + 6, 3))
        m = m + 1
     Next
    Set myArrayList = Nothing: Erase arr1
    Set myArrayList2 = Nothing: Erase arr2
End Sub
'++++++++++++++++++++++++++++++++++++++++++++++++
Sub EXTARCT_for_matloub_2()
Dim arr, tt%
arr = Array("D", "E", "F", "G", "H", "I", "J", "K", "L", "M")
For tt = LBound(arr) To UBound(arr)
Call For_matloub_2(arr(tt))
Next
Erase arr
End Sub

الملف للمرة الثالثة

Exam _new.xlsm

[الرائد77]

أخي سليم . أصبح الملف ثقيل جدا عند التنفيذ. لماذا أضفت اسم الاستاذ؟ أنا أريد ارقام قاعات فقط . مثل الملف السابق .فقط تغير مثلا 

احتياط :28 . الى احتياط :04 حيث 04 يمثل رقم القاعة 

[سليم حاصبيا]

هل ترى ملف بحجم 44.8 هو ثقيل  

بصراحة لم افهم ماذا تريد بالضبط

حاول تعبئة عامود  واحد ببيانات متوقعة (يدوياً)

 

[الرائد77]

شكرا أخي سليم هذا الشرح في المرفق.

توضيح المطلوب 2.xlsm