Modifying existing dynamic questionnaire

[techfreak]

Hi all,

so I have a dynamic macro based questionnaire which allows me to set the parameters of the questionnaire, such as the type of question and answer being provided - whether the answer is a radio button, check box, or free type text box. I can then click on the "create questionnaire button" and it opens up and saves the questionnaire to a separate excel file.

The original file also then allows me to collate the responses. This works well but it is limited and I'd like to expand the capabilities.

I'd like to be able to:

1. add further options in the control type legends: i.e. instead of radio, check, text I would also like to add lists.
2. make the questionnaire dynamic, so depending on a previous - e.g. a "no" answer (which can be answered by the user selecting the a radio button) it will remove unnecessary questions.
3. add weightings to certain questions so that once the questionnaire completes the weightings are averaged and a specific output is shown.

can someone please help modify the vba so I can do this?

here's the code to create the questionnaire:

Sub evtCreateQuestionnaire()    
    Dim lngCtrlLeft         As Long
    Dim lngCtrlTop          As Long
    Dim intLoop             As Integer
    Dim intQues             As Integer
    Dim intColType          As Integer
    Dim intLbl              As Integer
    Dim intCtrlStartRow     As Integer
    Dim ole                 As OLEObject
    Dim wksControl          As Worksheet
    Dim wksQuestionnaire    As Worksheet
    Dim wbkNew              As Workbook
    
    Application.ScreenUpdating = False
    Application.StatusBar = "Creating Questionnaire..."
    Set wksControl = shtControl
    
    wksControl.Unprotect
    Set wbkNew = Application.Workbooks.Add(1)
    Set wksQuestionnaire = wbkNew.Worksheets(1)
    wksQuestionnaire.Name = "Questionnaire"
    
    'wksQuestionnaire.DrawingObjects.Delete
    
    lngCtrlLeft = 20
    lngCtrlTop = 25
    
    intColType = 1
    intLbl = 2
    
    intCtrlStartRow = 3
    
    With wksQuestionnaire.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 "Ques"
            Set ole = wksQuestionnaire.OLEObjects.Add("Forms.Label.1")
            intQues = intQues + 1
            Application.StatusBar = "Ques " & intQues & "..."
        Case "Radio"
            Set ole = wksQuestionnaire.OLEObjects.Add("Forms.OptionButton.1")
            ole.Object.GroupName = "QGrp" & CStr(intQues)
        Case "Check"
            Set ole = wksQuestionnaire.OLEObjects.Add("Forms.CheckBox.1")
            ole.Object.GroupName = "QGrp" & CStr(intQues)
        Case "Text"
            Set ole = wksQuestionnaire.OLEObjects.Add("Forms.TextBox.1")
        Case "Spin"
            Set ole = wksQuestionnaire.OLEObjects.Add("Forms.SpinButton.1")
        End Select
        
        If wksControl.Cells(intLoop, intColType).Value = "Ques" 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 = "Ques" Then
                ole.Object.Caption = CStr(intQues) & ". " & 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
    
    wksQuestionnaire.Rows(CStr(ole.TopLeftCell.Offset(3).Row) & ":" & CStr(wksQuestionnaire.Rows.Count)).Hidden = True
    Application.StatusBar = "Saving Questionnaire to Desktop..."
    
    wbkNew.SaveAs CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & "Questionnaire " & Format(Now, "dd-mmm-yy hh-mm-ss")
    DoEvents
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox "Questionnaire saved on Desktop", vbInformation, "Questionnaire Utility"
    
    Set ole = Nothing
    Set wksControl = Nothing
    Set wksQuestionnaire = Nothing
    Set wbkNew = Nothing
End Sub


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


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


   Dim objControl    As OLEObject
   Dim strQues       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
         strQues = objControl.Object.Caption
         strAns = ""
         If lngAnsRow = 1 Then
            wksTgt.Cells(lngAnsRow, lngCol).Value = strQues
            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


Private Sub ListBox1_Click()


End Sub

TIA