طلب توليد أرقام جلوس تلاميذ بحيث ألا يجلس تلميذان ينتميان لنفس القسم متتاليان

[hicham2610]

السلام عليكم

من فضلكم في هذا الملف كيف أبرمج زر الورقة g ?

او اقتراح معادلة مناسبة

بحيث يعيد ترتتيب أسماء التلاميذ  التي في الورقة g عمود D بحيث لايجلس تلميذان ينتميان إلى نفس القسم عمود F متتاليان

وهكذا لكل اللائحة التي في الورقة g

وجزاكم الله خيرا

 

الملف1.xlsm

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

1- تم اضافة صفحة جدبدة باسم  SALIM تأخذ بياناتها عشوائياً من الشيت G وذلك كي تبقي الشيت الاساسي على بياناتها دون تغيير
2- لا حاجة لادراح اكثر من 20---30 اسم لأان الماكروالذي يعمل على صف واحد يمكنه العملعلى الالوف

3-البيانات في الصفحة G عشوائية لمعرفة مدى فعالية الماكرو (يمكنك استبدالها من الشيت الاساسي عندك غن طريق النسخ واللصق وزيادتتها الى فدر ما تشاء)

4- جرب هذا الملف في الصفحة SALIM بعد الضغط على الزر  Run  يظهر عندك ماذا كنت تريد

5 _الكود

 

Option Explicit

Sub Salim_Mcro()
 Dim g As Worksheet
 Dim S As Worksheet
 Dim Lg%, Ls%, i%, k%, M%, X, Y
 Set g = Sheets("g")
 Set S = Sheets("SALIM")
 Dim Arr()
 Lg = g.Cells(Rows.Count, 1).End(3).Row
  If Lg < 17 Then Exit Sub
  Ls = S.Cells(Rows.Count, 1).End(3).Row
  If Ls < 17 Then Ls = 17
 S.Range("A17:F" & Ls).ClearContents
   
 ReDim Arr(1 To Lg - 16)

   Dim ST$
    Dim oBJ As Object
    Set oBJ = CreateObject("System.Collections.Sortedlist")
    For i = 1 To Lg - 16
    
     Arr(i) = Application.Transpose(Sheets("g").Range("A" & i + 16).Resize(, 5))
     Arr(i) = Application.Transpose(Arr(i))
     ST = Join(Arr(i), "*")
     Randomize
     Y = Rnd()
     oBJ.Add Y, ST
    Next
    X = oBJ.Count
    M = 17
    For k = 0 To oBJ.Count - 1
        S.Cells(M, 1).Resize(, 5) = Split(oBJ.GetBYINDEX(k), "*")
        M = M + 1
    Next
End Sub

الملف مرفق

 

HiCham2610.xlsm

1- تم اضافة صفحة جدبدة باسم  SALIM تأخذ بياناتها عشوائياً من الشيت G وذلك كي تبقي الشيت الاساسي على بياناتها دون تغيير
2- لا حاجة لادراح اكثر من 20---30 اسم لأان الماكروالذي يعمل على صف واحد يمكنه العملعلى الالوف

3-البيانات في الصفحة G عشوائية لمعرفة مدى فعالية الماكرو (يمكنك استبدالها من الشيت الاساسي عندك غن طريق النسخ واللصق وزيادتتها الى فدر ما تشاء)

4- جرب هذا الملف في الصفحة SALIM بعد الضغط على الزر  Run  يظهر عندك ماذا كنت تريد

5 _الكود

 

Option Explicit

Sub Salim_Mcro()
 Dim g As Worksheet
 Dim S As Worksheet
 Dim Lg%, Ls%, i%, k%, M%, X, Y
 Set g = Sheets("g")
 Set S = Sheets("SALIM")
 Dim Arr()
 Lg = g.Cells(Rows.Count, 1).End(3).Row
  If Lg < 17 Then Exit Sub
  Ls = S.Cells(Rows.Count, 1).End(3).Row
  If Ls < 17 Then Ls = 17
 S.Range("A17:F" & Ls).ClearContents
   
 ReDim Arr(1 To Lg - 16)

   Dim ST$
    Dim oBJ As Object
    Set oBJ = CreateObject("System.Collections.Sortedlist")
    For i = 1 To Lg - 16
    
     Arr(i) = Application.Transpose(Sheets("g").Range("A" & i + 16).Resize(, 5))
     Arr(i) = Application.Transpose(Arr(i))
     ST = Join(Arr(i), "*")
     Randomize
     Y = Rnd()
     oBJ.Add Y, ST
    Next
    X = oBJ.Count
    M = 17
    For k = 0 To oBJ.Count - 1
        S.Cells(M, 1).Resize(, 5) = Split(oBJ.GetBYINDEX(k), "*")
        M = M + 1
    Next
End Sub

الملف مرفق

 

[أحمد يوسف]

hicham2610

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

أين الضغط على الإعــــــجــاب لإجابة الأستاذ سليم ؟!!💙

حفظ الله دائما لبنان استاذ سليم وزال عنها الدمار وسلم الله اهلها من كل سوء

[abouelhassan]

شكر وتقدير واحترام من اخيك استاذ سليم