Macro Intro
This is an Excel macro that generates a custom questionnaire to complete. The Role field is used to determine what questions display for specific users. The Role selection options can be customized directly in the Roles Worksheet. Once a user selects their Role, they can click Generate to see what questions they need to complete to finish the questionnaire. Certain questions can display for specific Roles by indicating the questions number in the columns adjacent to a specific role in the Roles Worksheet. This helps ensures that only the questions that are necessary for users are completed. The questions and answers can be customized by updating the Questions Worksheet. Three questions types exist: Yes/No, List, and Free Text and can be set in the second row of the Questions Worksheet. When creating a List question enter the answers in the rows below. After a user has completed all the required questions, they can click Finish to create a separate Excel Workbook with all the populated answers. This new Excel Workbook will be saved to the same location as the Active Workbook. You can customize where this new file is saved making it easy to know when someone has completed a questionnaire and is awaiting review. By Default, the new Excel Workbook file name will be the Role selected followed by the Date and Time. There is also the option to send this separate Excel Workbook in an Outlook email with a couple updates to the VBA code. There is always a better way with VBA and this Excel macro helps standardize the collection of answers to specific questions. This can help lead to a more formal review process and eliminate mistakes. It is easy to restrict access to edit this questionnaire by protecting the Roles and Questions Worksheets with a password. To do this navigate to the Review tab and click the Protect Sheet button.Use the following link to download the Excel Workbook seen in the videos below: Excel Custom Questionnaire to File
See it in Action
Watch this video to see this macro in action.Code
Here is the code for this macro. Make sure the following References are setup before running it: Visual Basic For Applications, Microsoft Excel 16.0 Object Library***Recent Code Updates
04.27.2021 Updated Role Questions handling to use an Array to remedy issue where the wrong questions ended up in the wrong roles. |
'Leverage & Lean "Less Clicks, More Results" Sub GenerateCustomQuestionnairetoFile() ' Means variable is in use Dim Answers As Integer ' Dim Column As String ' Dim Counter As Integer ' Dim Remove As Integer ' Dim Role As String ' Dim RoleCounter As Integer ' Dim Roles As Integer ' Dim RoleQuestions As String ' Dim ThisRolesQuestion As Variant ' Dim ThisRolesQuestions() As String ' Dim Question As String ' Dim QuestionCounter As Integer ' Dim Questions As Integer ' Dim QuestionnaireWorksheetName As String ' On Error GoTo LeverageLean QuestionnaireWorksheetName = ActiveSheet.Name 'Determine the Questionnaire Worksheet Name Role = Worksheets(QuestionnaireWorksheetName).Cells(5, 3).Value 'Determine the Role selected If Role = "" Then MsgBox "Please select a Role before Generating the Questionnaire. Stay Awesome!" Exit Sub End If Remove = 10 'Set Remove Counter to Delete Prior Answer Entries Do Until Worksheets(QuestionnaireWorksheetName).Cells(Remove, 2).Value = "" Remove = Remove + 1 Loop If Remove > 10 Then Worksheets(QuestionnaireWorksheetName).Range("B10:C" & Remove - 1).Select Selection.Delete Shift:=xlUp Worksheets(QuestionnaireWorksheetName).Range("B9").Select End If Roles = Worksheets("Roles").Cells(Rows.Count, 1).End(xlUp).Row 'Identify Last Role Row Number RoleCounter = 1 'Set Role Counter to loop through all Roles Do Until RoleCounter > Roles 'Determine what Questions are necessary for the selected Role If Role = Worksheets("Roles").Cells(RoleCounter, 1).Value Then QuestionCounter = 2 Do Until Worksheets("Roles").Cells(RoleCounter, QuestionCounter).Value = "" If RoleQuestions = "" Then RoleQuestions = Worksheets("Roles").Cells(RoleCounter, QuestionCounter).Value 'Set String with all Questions of Role ElseIf RoleQuestions <> "" Then RoleQuestions = RoleQuestions & "," & Worksheets("Roles").Cells(RoleCounter, QuestionCounter).Value 'Set String with all Questions of Role End If QuestionCounter = QuestionCounter + 1 Loop End If RoleCounter = RoleCounter + 1 Loop Questions = Worksheets("Questions").Cells(1, Columns.Count).End(xlToLeft).Column 'Identify Last Question Column Number QuestionCounter = 1 'Reset QuestionCounter to populate Questions to Questionnaire Counter = 10 If RoleQuestions = "" Then Do Until QuestionCounter > Questions 'Populate the Questions to complete Question = Worksheets("Questions").Cells(1, QuestionCounter).Value 'Determine the Question selected Worksheets(QuestionnaireWorksheetName).Range("B" & Counter & ":C" & Counter).Select Selection.Insert Shift:=xlDown 'Insert a new row for next Question Worksheets(QuestionnaireWorksheetName).Cells(Counter, 2).Value = Question 'Set next Question If Worksheets("Questions").Cells(2, QuestionCounter).Value = "Yes/No" Then 'Yes/No Answer Type Worksheets(QuestionnaireWorksheetName).Range("C" & Counter).Interior.ColorIndex = 0 With Worksheets(QuestionnaireWorksheetName).Range("C" & Counter).Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="Yes, No" End With ElseIf Worksheets("Questions").Cells(2, QuestionCounter).Value = "List" Then 'List Answer Type Worksheets(QuestionnaireWorksheetName).Range("C" & Counter).Interior.ColorIndex = 0 Column = Split(Cells(1, QuestionCounter).Address, "$")(1) Answers = Worksheets("Questions").Cells(Rows.Count, QuestionCounter).End(xlUp).Row 'Identify Last Role Row Number With Worksheets(QuestionnaireWorksheetName).Range("C" & Counter).Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Questions!" & Column & "3:" & Column & Answers End With ElseIf Worksheets("Questions").Cells(2, QuestionCounter).Value = "Free Text" Then 'Free Text Answer Type Worksheets(QuestionnaireWorksheetName).Range("C" & Counter).Interior.ColorIndex = 0 Worksheets(QuestionnaireWorksheetName).Range("C" & Counter).Validation.Delete Worksheets(QuestionnaireWorksheetName).Range("C" & Counter).Value = "FREE TEXT" End If QuestionCounter = QuestionCounter + 1 'Reset QuestionCounter to populate Questions to Questionnaire Counter = Counter + 1 Loop ElseIf RoleQuestions <> "" Then Do Until QuestionCounter > Questions 'Populate the Questions to complete ThisRolesQuestions = Split(RoleQuestions, ",") 'Separate each Attachment found in the Location field For Each ThisRolesQuestion In ThisRolesQuestions If ThisRolesQuestion = QuestionCounter Then Question = Worksheets("Questions").Cells(1, QuestionCounter).Value 'Determine the Question selected Worksheets(QuestionnaireWorksheetName).Range("B" & Counter & ":C" & Counter).Select Selection.Insert Shift:=xlDown 'Insert a new row for next Question Worksheets(QuestionnaireWorksheetName).Cells(Counter, 2).Value = Question 'Set next Question If Worksheets("Questions").Cells(2, QuestionCounter).Value = "Yes/No" Then 'Yes/No Answer Type Worksheets(QuestionnaireWorksheetName).Range("C" & Counter).Interior.ColorIndex = 0 With Worksheets(QuestionnaireWorksheetName).Range("C" & Counter).Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="Yes, No" End With ElseIf Worksheets("Questions").Cells(2, QuestionCounter).Value = "List" Then 'List Answer Type Worksheets(QuestionnaireWorksheetName).Range("C" & Counter).Interior.ColorIndex = 0 Column = Split(Cells(1, QuestionCounter).Address, "$")(1) Answers = Worksheets("Questions").Cells(Rows.Count, QuestionCounter).End(xlUp).Row 'Identify Last Role Row Number With Worksheets(QuestionnaireWorksheetName).Range("C" & Counter).Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Questions!" & Column & "3:" & Column & Answers End With ElseIf Worksheets("Questions").Cells(2, QuestionCounter).Value = "Free Text" Then 'Free Text Answer Type Worksheets(QuestionnaireWorksheetName).Range("C" & Counter).Interior.ColorIndex = 0 Worksheets(QuestionnaireWorksheetName).Range("C" & Counter).Validation.Delete Worksheets(QuestionnaireWorksheetName).Range("C" & Counter).Value = "FREE TEXT" End If Counter = Counter + 1 End If Next QuestionCounter = QuestionCounter + 1 'Reset QuestionCounter to populate Questions to Questionnaire Loop End If Worksheets(QuestionnaireWorksheetName).Range("C10").Select 'Finish with first Answer selected Exit Sub LeverageLean: MsgBox (Err.Number & " - " & Err.Description & vbNewLine & vbNewLine & "Don't hesitate to email me: brentschneider@leveragelean.com") End Sub 'Leverage & Lean "Less Clicks, More Results" Sub FinishCustomQuestionnairetoFile() ' Means variable is in use Dim FileName As String ' Dim FilePath As String ' Dim NewEmail As Object ' Dim OutlookApp As Object ' Dim QuestionnaireWorksheetName As String ' Dim Remove As Integer ' Dim TempFilePath As String ' Dim TempWB As Workbook ' On Error GoTo LeverageLean Application.DisplayAlerts = False 'Hide Display Alerts Application.EnableEvents = False 'Hide Before Save Event Application.ScreenUpdating = False 'Hide Screen Updating QuestionnaireWorksheetName = ActiveSheet.Name 'Determine the Questionnaire Worksheet Name TempFilePath = Environ$("temp") & "\" 'Set the Temporary File Path for .xlsm Workbook FilePath = Left(ActiveWorkbook.FullName, Len(ActiveWorkbook.FullName) - Len(ActiveWorkbook.Name)) 'Active Workbook File Path FileName = Worksheets(QuestionnaireWorksheetName).Cells(5, 3).Value & "_" & Format(Date, "MM.DD.YYYY") & "_" & Format(Time, "hhmm") 'File Name for Active Workbook Copy CurrentRole_Date_Time.xlsx ActiveWorkbook.SaveCopyAs (TempFilePath & FileName & ".xlsm") 'Save a Copy of the Active .xlsm Workbook Set TempWB = Workbooks.Open(TempFilePath & FileName & ".xlsm") 'Open the Copy of the Active .xlsm Workbook With TempWB .SaveAs FileName:=FilePath & FileName & ".xlsx", FileFormat:=xlOpenXMLWorkbook 'Save Copy of Active .xlsm Workbook as .xlsx to FilePath .Close SaveChanges:=False 'Close the New .xlsx Workbook End With 'Set OutlookApp = CreateObject("Outlook.Application") 'Set Outlook Application 'Set NewEmail = OutlookApp.CreateItem(0) 'Create New Outlook Email 'With NewEmail '.To = "" '.Subject = "Questionnaire Completed: New File Saved " & FileName & ".xlsx" '.Body = "The " & Worksheets(QuestionnaireWorksheetName).Cells(2, 2).Value & " has recently been completed generating a new .xlsx file saved to " & FilePath '.Attachments.Add FilePath & FileName & ".xlsx" 'Add the New .xlsx Workbook as an Email attachment '.Display 'Display the Email before it is sending it '.Send 'Send the Email automatically 'End With Kill TempFilePath & FileName & ".xlsm" 'Delete the Temp .xlsm Workbook Set NewEmail = Nothing Set OutlookApp = Nothing Set TempWB = Nothing Remove = 10 'Set Remove Counter to Delete Completed Answer Entries Do Until Worksheets(QuestionnaireWorksheetName).Cells(Remove, 2).Value = "" Remove = Remove + 1 Loop If Remove > 10 Then Worksheets(QuestionnaireWorksheetName).Range("B10:C" & Remove - 1).Select Selection.Delete Shift:=xlUp Worksheets(QuestionnaireWorksheetName).Range("B9").Select End If Application.DisplayAlerts = True 'UnHide Display Alerts Application.EnableEvents = True 'UnHide Before Save Event Application.ScreenUpdating = True 'UnHide Screen Updating MsgBox "Thank you for completing this questionnaire! Stay Awesome!" Exit Sub LeverageLean: MsgBox (Err.Number & " - " & Err.Description & vbNewLine & vbNewLine & "Don't hesitate to email me: brentschneider@leveragelean.com") End Sub 'Stay Awesome
Customization
These segments of code can be customized to personalize this macro.Set the Answer column to No Fill
Populate the Answer field for Free Text Questions
The File Path where the New .xlsx Workbook will be saved. By Default, it will be saved to the Active Workbook’s file path
The File Name of the New .xlsx Workbook. By Default, it will be in the following format: SelectedRoleName_mm.dd.yyyy_hhmm.xlsx
Remove the ‘ from the following code lines to generate an email with the New .xlsx Workbook as an attachment
Enter in an email address for the To recipient field
Enter in text for the Subject field
Enter in text for the Email Body
Include the New .xlsx Workbook as an email attachment
Display the email before sending. (HIGHLY RECOMMENDED to automatically send this email without displaying it)
Send the email after the completion of the questionnaire
The Message Box that displays when someone completes the questionnaire