VBA Macro used in the Microsoft Office Excel Application

Excel Custom Questionnaire to File | VBA Macro #34

Share on facebook
Share on twitter
Share on linkedin

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.


The 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

'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 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

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 = ""
RoleQuestions = RoleQuestions & ", " & Worksheets("Roles").Cells(RoleCounter, QuestionCounter).Value 'Set String with all Questions of Role
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
If InStr(1, RoleQuestions, QuestionCounter) <> 0 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
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

Macro Monday

Here is the Macro Monday video this macro was featured in. Watch this video to learn how to get the most out of this macro and start using it today!

Customization

These lines of code can be customized to personalize this macro.
57, 63, 71, 86, 92, 100 Worksheets(QuestionnaireWorksheetName).Range(“C” & Counter).Interior.ColorIndex = 0 Set the Answer column to No Fill
73 and 102 Worksheets(QuestionnaireWorksheetName).Range(“C” & Counter).Value = “FREE TEXT” Populate the Answer field for Free Text Questions
138. FilePath = Left(ActiveWorkbook.FullName, Len(ActiveWorkbook.FullName) – Len(ActiveWorkbook.Name)) ‘Active Workbook File Path The File Path where the New .xlsx Workbook will be saved. By Default, it will be saved to the Active Workbook’s file path
139. 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 The File Name of the New .xlsx Workbook. By Default, it will be in the following format: SelectedRoleName_mm.dd.yyyy_hhmm.xlsx
148 through 158 ‘Set OutlookApp = CreateObject(“Outlook.Application”) ‘Set Outlook Application Remove the ‘ from the following code lines to generate an email with the New .xlsx Workbook as an attachment
152. ‘.To = “” Enter in an email address for the To recipient field
153. ‘.Subject = “Questionnaire Completed: New File Saved ” & FileName & “.xlsx” Enter in text for the Subject field
154. ‘.Body = “The ” & Worksheets(QuestionnaireWorksheetName).Cells(2, 2).Value & ” has recently been completed generating a new .xlsx file saved to ” & FilePath Enter in text for the Email Body
155. ‘.Attachments.Add FilePath & FileName & “.xlsx” ‘Add the New .xlsx Workbook as an Email attachment Include the New .xlsx Workbook as an email attachment
156. ‘.Display ‘Display the Email before it is sending it Display the email before sending. HIGHLY RECOMMENDED to automatically send this email from code line #157 without displaying
157. ‘.Send ‘Send the Email automatically Send the email after the completion of the questionnaire
180. MsgBox “Thank you for completing this questionnaire! Stay Awesome!” The Message Box that displays when someone completes the questionnaire

Subscribe
Notify of
0 Comments
Inline Feedbacks
View all comments

Search for Excel Macros

Recent Macros

VBA Macro used in the Microsoft Office Outlook Application

Outlook Greeting and Goodbye Contacts | VBA Macro #35

The Greeting and Goodbye Contact macro automates the entry of a Greeting “Good Morning” or “Hello” followed by the First Name of the recipient you are emailing. To identify the First Name this macro uses the recipient’s email address to loop through all the existing contact records for a matching email address. If a match is found the contact’s First Name field value is used in the beginning of the email. The appropriate Greeting and Goodbye is determined by the current time and the day of the week. The Greeting and Goodbye Contacts macro helps you deliver better customer service and create better connections with your clients!

VBA Macro used in the Microsoft Office Outlook Application

Outlook Hello Contacts | VBA Macro #33

Starting an email with a Hello can look more personable with some VBA code! The Hello Contacts Outlook macro automates the entry of the text Hello followed by the First Name of the recipient you are emailing. This Outlook macro uses the recipient’s email address to loop through all the existing contact records for a matching email address. If a match is found the contact’s First Name field value is used in the beginning of the email. This macro can be fired from a custom button or trigger automatically when replying to an email.

VBA Macro used in the Microsoft Office Outlook Application

Outlook Reply with Email Template | VBA Macro #32

If you find yourself emailing the same response over and over you could create an Outlook Email Template. Email templates are a great way to save that perfectly drafted email and recall it again at a later date. One shortcoming in Outlook is that there isn’t an easy way to reply to an email directly with an email template. This is why we created the macro Reply with Email Template. This is an Outlook macro that will allow you to reply to an email with all the contents of a specific email template. You can run this macro for the current email selected in your inbox or from an open email. By Default, this macro will reply to all recipients. You can update the VBA code to only reply to the sender instead. Once running this Outlook macro will access your default email template file path and display an InputBox with all the available email templates to select from. Simply type the leading number of the email template you want to reply with and click Ok. This macro will finish by pulling in the selected email template’s contents to the active Outlook email body. If the template you selected has attachments these will also be attached to the email.

First time using VBA?

The Developer Tab is an additional section of the ribbon when activated allows you access to Visual Basic in Applications like Excel, Outlook, Word.
Setup Now
Once the Developer Tab is available you will have the capability to update your security to allow Macros to run in the current application.
Setup Now
A sub of code is a collection of objects and variables. For the code to successfully run a library of references needs to be set.
Setup Now

Looking for more?

Subscribe as an Insider to receive additional rights.

Contact Us

Looking to improve your computer processes?
Leverage & Lean is here to help!

Copyright © 2019 Leverage & Lean – Uptown Style WordPress theme by GoDaddy