Modify code to pre-populate textboxes based on database?
I found some very useful code from an expert 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
Recent comments
5 years 36 weeks ago
6 years 22 weeks ago
6 years 34 weeks ago
6 years 37 weeks ago
6 years 38 weeks ago
6 years 43 weeks ago
6 years 52 weeks ago
7 years 2 days ago
7 years 3 days ago
7 years 3 days ago