Create Dynamic Data Validation Drop Downs Using VBA
When a user enters values in a worksheet cell, data validation from a list provides a drop-down that the user can select to enter the data, ensuring consistent values.
These drop-down validations can be created from VBA instead of hand-coded by the user. In the VBA code illustrated below, the validation drop-down lists are not derived from literals, but reference a range of values from a separate "Validation Profile" worksheet (in the same workbook).
The next illustration shows a sample "Validation Profile" worksheet, in which the proper "list of values" for validation is created for six different fields: Technician, Time, City, Type, Home and By.
"City", for example, uses a validation range of "D3 through D17" as the correct list of values.
When the VBA code creates validations on a "Master Schedule" worksheet, it references the range of values for each of the six distinct columns (B through G) in the "Validation Profile" worksheet. The code example populates drop-downs in 6 different columns on the "Master Schedule" worksheet by referencing ranges of values on the "Validation Profile" worksheet.
As each new row on the "Master Schedule" worksheet is created, the drop downs pertaining to that row are also created, and in addition, the entire technician row color is formatted to match the colors in Column A of the "Validation Profile" worksheet.
Program Code
Option Explicit
' ********************************************************
' Workbook and Worksheet Variables
' ********************************************************
Dim wkbSchedule As Workbook
Dim wksMainCalendar As Worksheet
Dim wksProfile As Worksheet
' ********************************************************
' Row Counters
' ********************************************************
Dim lngNumberOfScheduleRows As Long
Dim lngScheduleCurrentRow As Long
Dim lngNumberOfProfileTechs As Long
Dim lngNumberOfProfileTimes As Long
Dim lngNumberOfProfileCities As Long
Dim lngNumberOfProfileTypes As Long
Dim lngNumberOfProfileHomes As Long
Dim lngNumberOfProfileBy As Long
' ********************************************************
' Drop Down Formulas
' ********************************************************
Dim strTechFormula As String
Dim strTimeFormula As String
Dim strCityFormula As String
Dim strTypeFormula As String
Dim strHomeFormula As String
Dim strByFormula As String
' ********************************************************
' Other Variables
' ********************************************************
Dim dteLastDateOnSchedule As Date
Dim dteScheduleDate As Date
Dim dteEndDate As Date
Dim lngThemeColor As Long
Dim dblTintAndShade As Double
Dim lngColumn As Long
Dim strDayOfWeek As String
Public Sub CreateANewCalendarMonth()
' ********************************************************
' Application Screen Updating
' ********************************************************
Application.ScreenUpdating = False
' ********************************************************
' Initialize Workbook and Worksheet Variables
' ********************************************************
Set wkbSchedule = ThisWorkbook
Set wksMainCalendar = wkbSchedule.Sheets(1)
Set wksProfile = wkbSchedule.Sheets("Profiles")
' ********************************************************
' Count Rows In Main Calendar And Profiles
' ********************************************************
lngNumberOfScheduleRows = wksMainCalendar.Cells(Rows.Count, "A").End(xlUp).Row
lngNumberOfProfileTechs = wksProfile.Cells(Rows.Count, "B").End(xlUp).Row
lngNumberOfProfileTimes = wksProfile.Cells(Rows.Count, "C").End(xlUp).Row
lngNumberOfProfileCities = wksProfile.Cells(Rows.Count, "D").End(xlUp).Row
lngNumberOfProfileTypes = wksProfile.Cells(Rows.Count, "E").End(xlUp).Row
lngNumberOfProfileHomes = wksProfile.Cells(Rows.Count, "F").End(xlUp).Row
lngNumberOfProfileBy = wksProfile.Cells(Rows.Count, "G").End(xlUp).Row
' ********************************************************
' Create The DropDown Formulas
' ********************************************************
strTechFormula = "=Profiles!$B$3:$B$" & lngNumberOfProfileTechs
strTimeFormula = "=Profiles!$C$3:$C$" & lngNumberOfProfileTimes
strCityFormula = "=Profiles!$D$3:$D$" & lngNumberOfProfileCities
strTypeFormula = "=Profiles!$E$3:$E$" & lngNumberOfProfileTypes
strHomeFormula = "=Profiles!$F$3:$F$" & lngNumberOfProfileHomes
strByFormula = "=Profiles!$G$3:$G$" & lngNumberOfProfileBy
lngScheduleCurrentRow = lngNumberOfScheduleRows + 1
If Not IsDate(wksMainCalendar.Cells(lngNumberOfScheduleRows, 1)) Then
MsgBox ("Last Row Column A Is Not A Valid Date - Please Correct")
Exit Sub
End If
' ********************************************************
' Get Last Date
' ********************************************************
dteLastDateOnSchedule = wksMainCalendar.Cells(lngNumberOfScheduleRows, 1)
dteScheduleDate = dteLastDateOnSchedule
' ********************************************************
' Calculate Current Month End Point
' ********************************************************
If Day(dteScheduleDate) > 15 Then
dteEndDate = DateSerial(Year(dteScheduleDate), Month(dteScheduleDate) + 2, 0)
Else
dteEndDate = DateSerial(Year(dteScheduleDate), Month(dteScheduleDate) + 1, 0)
End If
' ********************************************************
' Make Sure End Point is Not Saturday or Sunday
' ********************************************************
If Format(dteEndDate, "ddd") = "Sat" Then
dteEndDate = dteEndDate - 1
ElseIf Format(dteEndDate, "ddd") = "Sun" Then
dteEndDate = dteEndDate - 2
End If
' ********************************************************
' Start With The Next Day After The Last Date
' ********************************************************
dteScheduleDate = dteScheduleDate + 1
' ********************************************************
' Add Monthly Header
' ********************************************************
wksMainCalendar.Range("A1:T1").Copy wksMainCalendar.Cells(lngScheduleCurrentRow, 1)
wksMainCalendar.Rows(lngScheduleCurrentRow).RowHeight = 31.5
' ********************************************************
' Loop Through All The Days, Skipping Saturday And Sunday
' ********************************************************
Do While dteScheduleDate <= dteEndDate
If Format(dteScheduleDate, "ddd") = "Sat" Or _
Format(dteScheduleDate, "ddd") = "Sun" Then
GoTo DateLoop
End If
Call CreateSingleDaySchedule
DateLoop:
dteScheduleDate = dteScheduleDate + 1
Loop
' ********************************************************
' Finish Out Until Friday
' ********************************************************
Do While Format(dteScheduleDate, "ddd") <> "Sat"
Call CreateSingleDaySchedule
dteScheduleDate = dteScheduleDate + 1
Loop
' ********************************************************
' Go To The Top of the Main Worksheet
' ********************************************************
wksMainCalendar.Select
wksMainCalendar.Cells(1, 1).Select
' ********************************************************
' Application Screen Updating
' ********************************************************
Application.ScreenUpdating = True
End Sub
Private Sub CreateSingleDaySchedule()
Dim i As Long
For i = 3 To lngNumberOfProfileTechs
' ********************************************************
' Row 1 Of Tech
' ********************************************************
lngScheduleCurrentRow = lngScheduleCurrentRow + 1
Call PopulateDropDowns(strTechFormula, 2)
Call PopulateDropDowns(strTimeFormula, 4)
Call PopulateDropDowns(strCityFormula, 9)
Call PopulateDropDowns(strTypeFormula, 13)
Call PopulateDropDowns(strHomeFormula, 14)
Call PopulateDropDowns(strByFormula, 19)
wksMainCalendar.Cells(lngScheduleCurrentRow, 1).Value = dteScheduleDate
wksMainCalendar.Cells(lngScheduleCurrentRow, 2).Value = wksProfile.Cells(i, 2).Value
strDayOfWeek = Format(dteScheduleDate, "ddd")
If strDayOfWeek = "Thu" Then
strDayOfWeek = "Th"
Else
strDayOfWeek = Left(strDayOfWeek, 1)
End If
wksMainCalendar.Cells(lngScheduleCurrentRow, 3).Value = strDayOfWeek
wksMainCalendar.Cells(lngScheduleCurrentRow, 4).Value = "8:30-9:30"
lngThemeColor = wksProfile.Cells(i, 1).Interior.ThemeColor
dblTintAndShade = wksProfile.Cells(i, 1).Interior.TintAndShade
Range(wksMainCalendar.Cells(lngScheduleCurrentRow, 1), wksMainCalendar.Cells(lngScheduleCurrentRow, 20)).Interior.ThemeColor = lngThemeColor
Range(wksMainCalendar.Cells(lngScheduleCurrentRow, 1), wksMainCalendar.Cells(lngScheduleCurrentRow, 20)).Interior.TintAndShade = dblTintAndShade
' ********************************************************
' Row 2 Of Tech
' ********************************************************
lngScheduleCurrentRow = lngScheduleCurrentRow + 1
Call PopulateDropDowns(strTechFormula, 2)
Call PopulateDropDowns(strTimeFormula, 4)
Call PopulateDropDowns(strCityFormula, 9)
Call PopulateDropDowns(strTypeFormula, 13)
Call PopulateDropDowns(strHomeFormula, 14)
Call PopulateDropDowns(strByFormula, 19)
' ********************************************************
' Row 3 Of Tech
' ********************************************************
lngScheduleCurrentRow = lngScheduleCurrentRow + 1
Call PopulateDropDowns(strTechFormula, 2)
Call PopulateDropDowns(strTimeFormula, 4)
Call PopulateDropDowns(strCityFormula, 9)
Call PopulateDropDowns(strTypeFormula, 13)
Call PopulateDropDowns(strHomeFormula, 14)
Call PopulateDropDowns(strByFormula, 19)
wksMainCalendar.Cells(lngScheduleCurrentRow, 1).Value = dteScheduleDate
wksMainCalendar.Cells(lngScheduleCurrentRow, 2).Value = wksProfile.Cells(i, 2).Value
wksMainCalendar.Cells(lngScheduleCurrentRow, 3).Value = strDayOfWeek
wksMainCalendar.Cells(lngScheduleCurrentRow, 4).Value = "12:30-1:30"
lngThemeColor = wksProfile.Cells(i, 1).Interior.ThemeColor
dblTintAndShade = wksProfile.Cells(i, 1).Interior.TintAndShade
Range(wksMainCalendar.Cells(lngScheduleCurrentRow, 1), wksMainCalendar.Cells(lngScheduleCurrentRow, 20)).Interior.ThemeColor = lngThemeColor
Range(wksMainCalendar.Cells(lngScheduleCurrentRow, 1), wksMainCalendar.Cells(lngScheduleCurrentRow, 20)).Interior.TintAndShade = dblTintAndShade
' ********************************************************
' Row 4 Of Tech
' ********************************************************
lngScheduleCurrentRow = lngScheduleCurrentRow + 1
Call PopulateDropDowns(strTechFormula, 2)
Call PopulateDropDowns(strTimeFormula, 4)
Call PopulateDropDowns(strCityFormula, 9)
Call PopulateDropDowns(strTypeFormula, 13)
Call PopulateDropDowns(strHomeFormula, 14)
Call PopulateDropDowns(strByFormula, 19)
Next i
End Sub
Private Sub PopulateDropDowns(strProfileDropDown, lngColumnParam)
With wksMainCalendar.Cells(lngScheduleCurrentRow, lngColumnParam).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertInformation, Operator:= _
xlBetween, Formula1:=strProfileDropDown
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = False
.ShowError = False
End With
End Sub