Modify code to pre-populate textboxes based on database?

[kcmuppet]

Hi

I found some very useful code here, that generates a questionnaire from an inputs spreadsheet.


Is there a way to pre-populate some of the fields based on records in another worksheet? e.g. look in a database spreadsheet as it generates the form, pre-populate with fields from each row (record) and then save a copy of the form as a separate work sheet with the filename according to one of the fields (something like "First Initial - Last Name - Membership Number.xlsx")?

The author's code (Vishesh):

Option Explicit

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