انشاء استبيان او اختبار

Create a questionnaire or test

انشاء استبيان او اختبار

قالب جاهز للعمل مباشرة 

يمكنك من خلاله انشاء استبيان أو استخدامه فى إنشاء اختبارات 

بشكل جميل وبسيط وسهل التعامل معه 

تجد بالقالب شيت واحد فقط 

من خلاله يتم انشاء الاستبيان 

خطوات العمل لإنشاء الاستبيان او الاختبار كما تريد

1 - بالخلية ( B1 ) تضع عنوان للإستبيان أو الاختبار .

2 - تقوم بإدخال الأسئلة والاجابات بالعمود ( B ) 

2- بالعمود ( A ) تحدد السؤال وطبيعة الاختيار من خلال 

القائمة المنسدلة التى تظهر لك ومحتوياتها كالتالي  :

•  Ques اذا كان هذا هو السؤال وسيتغير الى اللون البنفسجي بواسطه التنسيق الشرطي
• Radio وهى ايقونة تتيح للمستخدم اختيار اجابة واحده فقط من الاختيارات الموجوده
• Check وهى ايقونة تتيح للمستخدم اختيار اكثر من اجابة أو اختيارهم جميعا 
• Text وهو صندوق ادخال يسمح للمستخدم بإدخال نص كتابي 

3 - تجد بالشيت زر باللون الأحمر وهو بعد اتمام ادخال الأسئلة والاجابات 

     تضغط على هذا الزر لكى يتم انشاء الاستبيان او الاختبار بملف اكسل مستقل 

4 - بعد الاجابة على الأسئلة التى بالاستبيان او الاختبار والحفظ 

     يمكنك الضغط على الزر ذا اللون البنفسجي 

     يظهر لك مربع حوار ،، تختار منه ملف الاستبيان او الاختبار 

     عند استدعاؤه يتم فتح الملف وستجد الاسئلة والاجابات الذى قام المستخدم بإدخالها 

يحتوى القالب على أكواد VBA ،، تجد تلك الأكواد بحدث الشيت نفسه الخاص بتصميم الاستبيان او الاختبار

والمسمى Control 

القالب يعمل فى حالة تفعيل الماكرو (( عليك بخفض مستوى أمان الماكرو لكى يعمل الملف بشكل سليم ))

لمعرفة كيف يتم خفض مستوى الأمان قم بالإطلاع على الموضوع بالرابط التالي اضغط هنا

الأكواد المستخدمة

'Permits any person to use this code provided that the source is mentioned
'https://elshriefacademy.blogspot.com

Sub evtCreateQuezprogram()
    
    Dim lngCtrlLeft         As Long
    Dim lngCtrlTop          As Long
    Dim intLoop             As Integer
    Dim intQuez            As Integer
    Dim intColType          As Integer
    Dim intLbl              As Integer
    Dim intCtrlStartRow     As Integer
    Dim ole                 As OLEObject
    Dim wksControl          As Worksheet
    Dim wksQuezprogram    As Worksheet
    Dim wbkNew              As Workbook
    
    Application.ScreenUpdating = False
    Application.StatusBar = "Creating Quez program ..."
    Set wksControl = shtControl
    
    wksControl.Unprotect
    Set wbkNew = Application.Workbooks.Add(1)
    Set wksQuezprogram = wbkNew.Worksheets(1)
    wksQuezprogram.Name = "Quez program "
    
    'wksQuezprogram .DrawingObjects.Delete
    
    lngCtrlLeft = 20
    lngCtrlTop = 25
    
    intColType = 1
    intLbl = 2
    
    intCtrlStartRow = 3
    
    With wksQuezprogram.Range("C1")
        .Value = wksControl.Range("B1").Value
        .Font.Size = 20
        .Font.Bold = True
    End With
    For intLoop = intCtrlStartRow To wksControl.Range("A1").CurrentRegion.Rows.Count
        Select Case wksControl.Cells(intLoop, intColType).Value
        Case "Quez"
            Set ole = wksQuezprogram.OLEObjects.Add("Forms.Label.1")
            intQuez = intQuez + 1
            Application.StatusBar = "Quez " & intQuez & "..."
        Case "Radio"
            Set ole = wksQuezprogram.OLEObjects.Add("Forms.OptionButton.1")
            ole.Object.GroupName = "QGrp" & CStr(intQuez)
        Case "Check"
            Set ole = wksQuezprogram.OLEObjects.Add("Forms.CheckBox.1")
            ole.Object.GroupName = "QGrp" & CStr(intQuez)
        Case "Text"
            Set ole = wksQuezprogram.OLEObjects.Add("Forms.TextBox.1")
        Case "Spin"
            Set ole = wksQuezprogram.OLEObjects.Add("Forms.SpinButton.1")
        End Select
        
        If wksControl.Cells(intLoop, intColType).Value = "Quez" Then
            ole.Left = lngCtrlLeft - 5
            lngCtrlTop = lngCtrlTop + 15
            ole.Top = lngCtrlTop
        Else
            ole.Left = lngCtrlLeft
            ole.Top = lngCtrlTop
        End If
        If wksControl.Cells(intLoop, intColType).Value <> "Text" And wksControl.Cells(intLoop, intColType).Value <> "Spin" Then
            If wksControl.Cells(intLoop, intColType).Value = "Quez" Then
                ole.Object.Caption = CStr(intQuez) & ". " & wksControl.Cells(intLoop, intLbl).Value
            Else
                ole.Object.Caption = wksControl.Cells(intLoop, intLbl).Value
            End If
            ole.Object.WordWrap = False
            ole.Object.AutoSize = True
        ElseIf wksControl.Cells(intLoop, intColType).Value = "Spin" Then
            ole.Left = ole.Left + 35
            ole.LinkedCell = ole.TopLeftCell.Offset(1, -1).Address
            ole.Object.Max = 0
            ole.Object.Max = 5
        ElseIf wksControl.Cells(intLoop, intColType).Value = "Text" Then
            ole.Object.AutoSize = False
            ole.Object.WordWrap = True
            ole.Object.IntegralHeight = False
            ole.Width = 175
            ole.Height = 17
        End If
        lngCtrlTop = lngCtrlTop + 16
    Next intLoop
    wksControl.Protect
    DoEvents
    wbkNew.Activate
    
    With ActiveWindow
        .DisplayGridlines = False
        .DisplayHeadings = False
    End With
    
    wksQuezprogram.Rows(CStr(ole.TopLeftCell.Offset(3).Row) & ":" & CStr(wksQuezprogram.Rows.Count)).Hidden = True
    Application.StatusBar = "Saving Quez program  to Desktop..."
    
    wbkNew.SaveAs CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & "Quez program  " & Format(Now, "dd-mmm-yy hh-mm-ss")
    DoEvents
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox "Quez program  saved on Desktop", vbInformation, "Quez program  Utility"
    
    Set ole = Nothing
    Set wksControl = Nothing
    Set wksQuezprogram = Nothing
    Set wbkNew = Nothing
End Sub

'Permits any person to use this code provided that the source is mentioned
'https://elshriefacademy.blogspot.com

Sub evtCollate()

   Dim lngAnsRow     As Long
   Dim wbkCollate    As Workbook
   Dim wbkResponse   As Workbook
   Dim varFiles
   Dim varFile
   
   varFiles = Application.GetOpenFilename(filefilter:="Excel Files (*.xls*), *.xls", Title:="Select file(s) to collate", MultiSelect:=True)
   If IsArray(varFiles) = True Then
      Application.ScreenUpdating = False
      Set wbkCollate = Workbooks.Add(1)
      wbkCollate.Worksheets(1).Name = "Collate"
      For Each varFile In varFiles
         lngAnsRow = lngAnsRow + 1
         Set wbkResponse = Workbooks.Open(varFile)
         Call GetAns(wbkResponse.Worksheets(1), wbkCollate.Worksheets(1), lngAnsRow)
         wbkResponse.Close False
      Next varFile
      Application.ScreenUpdating = True
   ElseIf varFiles = False Then
      GoTo ExitEarly
   End If
ExitEarly:
   On Error Resume Next
   Set wbkCollate = Nothing
   Set wbkResponse = Nothing
   Erase varFiles
   Erase varFile
End Sub

'Permits any person to use this code provided that the source is mentioned
'https://elshriefacademy.blogspot.com

Sub GetAns(wksSrc As Worksheet, wksTgt As Worksheet, lngAnsRow As Long)

   Dim objControl    As OLEObject
   Dim strQuez       As String
   Dim strAns        As String
   Dim lngCol        As Long
   
   For Each objControl In wksSrc.OLEObjects
      If TypeName(objControl.Object) = "Label" Then
         lngCol = lngCol + 1
         strQuez = objControl.Object.Caption
         strAns = ""
         If lngAnsRow = 1 Then
            wksTgt.Cells(lngAnsRow, lngCol).Value = strQuez
            wksTgt.Cells(lngAnsRow, lngCol).Font.Bold = True
         End If
      Else
         If TypeName(objControl.Object) = "OptionButton" Then
            If objControl.Object.Value = True Then
               strAns = strAns & ", " & objControl.Object.Caption
            End If
         End If
         If TypeName(objControl.Object) = "TextBox" Then
            If Trim(objControl.Object.Text) <> "" Then
               strAns = strAns & " - " & objControl.Object.Text
            End If
         End If
         If TypeName(objControl.Object) = "CheckBox" Then
            If objControl.Object.Value = True Then
               strAns = strAns & ", " & objControl.Object.Caption
            End If
         End If
         wksTgt.Cells(lngAnsRow + 1, lngCol).Value = Mid(strAns, 3, 999)
      End If
   Next objControl
   
   Set objControl = Nothing
End Sub

لتحميل النموذج أو الأكواد

Download ⇊