السلام عليكم ورحمة الله وبركاته

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



بفرض أن لديك في ورقة العمل Sheet2 مجموعة كبيرة من الأسئلة (بنك الأسئلة) ، والمطلوب هو توليد 10 أسئلة في كل مرة يتم تنفيذ الكود فيها ، وتظهر النتائج في ورقة العمل Sheet1



إليكم الكود المستخدم لهذه المهمة مع الشرح لأسطر الكود بالتفصيل
[p]

Sub Generate_Test()
    'الإعلان عن المتغيرات
    Dim i                   As Long
    Dim rowNum              As Long
    Dim qNum                As Long

    'إلغاء خاصية تحديث الشاشة لتسريع الكود
    Application.ScreenUpdating = False

    'تعيين قيمة للمتغير ليساوي عدد الأسئلة في ورقة بنك الأسئلة وهنا
    'استخدمنا دالة العد لتقوم بعد الخلايا في العمود الأول في ورقة الأسئلة
    qNum = Application.WorksheetFunction.CountA(Sheets("Sheet2").Columns(1))

    'بدء التعامل مع ورقة النتائج التي تريد توليد الأسئلة العشوائية بها
    With Sheets("Sheet1")

        'مسح محتويات النطاق الذي سيحتوي على النتائج
        .Range("A2:A10000").ClearContents

        'حلقة تكرارية من 1 إلى 10 ويمثل عدد الأسئلة المطلوب توليدها
        'إذا أردت أن تقوم بتوليد عدد أسئلة أكثر قم بتغيير الرقم 10
        For i = 1 To 10

'نقطة انتقال بحيث لو كان السؤال مكرر يرجع لتلك النقطة
Generate:
            'توليد رقم عشوائي بين 1 و أكبر عدد للأسئلة لاختيار صف عشوائي
            rowNum = Application.RoundUp(Rnd() * qNum, 0)

            'هذا الجزء للتأكد من أن السؤال غير مكرر حيث استخدمت دالة العد المشروط
            If Application.CountIf(.[A:A], Sheets("Sheet2").Cells(rowNum, "A")) = 0 Then

                'في حالة أن السؤال غير مكرر يتم جلب السؤال من ورقة الأسئلة
                .Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Sheets("Sheet2").Cells(rowNum, "A").Value
            Else

                'في حالة أن السؤال مكرر يتم الرجوع لنقطة الانتقال
                'لإعادة توليد رقم صف عشوائي جديد
                GoTo Generate

            'نهاية جملة الشرط
            End If

        'الانتقال للحلقة التالية أي للسؤال التالي
        Next i

    'نهاية التعامل مع ورقة العمل
    End With

    'إعادة تفعيل خاصية تحديث الشاشة
    Application.ScreenUpdating = True
End Sub

رابط الملف من هنا

إعداد وتقديم / ياسر خليل أبو البراء </pre>