This code will add a Data Validation In Cell Drop Down List of Dates to a Cell.
It requires that you pick a Sheet and Column for the list's Table of Dates [Which the code automatically builds for you!], to be used as the source for the DropDown dates. It also requires that you pick the Sheet and the Cell that gets the DropDown List in. The date to Start the list with and the number of dates to list in the DropDown are also set in the code. The code re-sets itself if you re-run it or change any of the basic date information. By changing the Lists Name you can use this code to maintain as many Date Drop Down Lists in a Workbook as you want!
Read the notes in the code to make these changes!
The code must be run from a Standard code module, like: Module1, do not use a Sheet module!
This is a working sample, to test it insert a copy of this code into Module1 of a Blank Workbook with at least Sheets1 & Sheets2, then run the code:
Sub myCalDates()
'Standard module code, like: Module1.
Dim datMyStartDate As Date, datMyNewDate As Date
Dim lngNextRow&, lngIntervalPeriod&, lngNumOfDatesToList&, lngColNum&
Dim strInCellDropDownSheetName$, strTableOfDatesDataSheetName$
Dim strDtIntervalType$, strCellToGetTheDropDownList$, strTableOfDatesColumn$
Dim strDateTableColumn$, strNameOfThisDateList$, strListLocation$
'Note: You must change the information below!
'Adjust the StartDate and the location of the DatesList data location,
'then adjust the In-Cell-Data-Validation-Drop-Down-List location below!
'*************** Default Date Information! **************************************
datMyStartDate = #1/1/2007# 'The Date to start the Date List With!
strDtIntervalType = "d" 'd=Day,m=Month,y=Year, the DropDown Date Intrerval!
lngIntervalPeriod = 1 'How many of the Interval Type to space dates by!
lngNumOfDatesToList = 366 'How many dates to list!
strTableOfDatesDataSheetName = "Sheet2" 'The Sheet Name that gets Date Data!
strTableOfDatesColumn = "A" 'The Column to use for this Date Data!
strInCellDropDownSheetName = "Sheet1" 'The Sheet Name of where the DropDown is!
strCellToGetTheDropDownList = "C6" 'The actual Cell that gets the DropDown List!
strNameOfThisDateList = "DateList" 'The name of this Date List!
'*************** Default Date Information! **************************************
On Error GoTo myNoNamedRng
ActiveWorkbook.Names("DateList").Delete
myNoNamedRng:
With Sheets(strTableOfDatesDataSheetName)
.Select
strDateTableColumn = strTableOfDatesColumn & ":" & strTableOfDatesColumn
.Columns(strDateTableColumn).ClearContents
.Columns(strDateTableColumn).NumberFormat = "[$-F800]dddd, mmmm dd, yyyy"
.Range(strTableOfDatesColumn & 1).Select
.Range(strTableOfDatesColumn & 1).Value = datMyStartDate
For lngNextRow = 2 To lngNumOfDatesToList
datMyNewDate = DateAdd(strDtIntervalType, lngIntervalPeriod, datMyStartDate)
.Range(strTableOfDatesColumn & lngNextRow).Value = datMyNewDate
datMyStartDate = datMyNewDate
Next lngNextRow
.Columns(strDateTableColumn).Columns.AutoFit
lngColNum = Range(strTableOfDatesColumn & ":" & strTableOfDatesColumn).Column
strMyListLocation = "=" & strTableOfDatesDataSheetName & _
"!R1C" & lngColNum & ":R" & lngNumOfDatesToList & "C" & lngColNum
ActiveWorkbook.Names.Add Name:=strNameOfThisDateList, _
RefersToR1C1:=strMyListLocation
.Range(strTableOfDatesColumn & 1).Select
End With
Sheets(strInCellDropDownSheetName).Select
Range(strCellToGetTheDropDownList).Select
With Selection.Validation
.Delete
strListLocation = "=" & strNameOfThisDateList
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=strListLocation
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = "Select Date!"
.InputMessage = "Pick the DATE you want from the list here!"
.ShowInput = True
.ShowError = False
End With
With Sheets(strInCellDropDownSheetName).Range(strCellToGetTheDropDownList)
.NumberFormat = "[$-F800]dddd, mmmm dd, yyyy"
.ColumnWidth = 28
.ClearContents
End With
End Sub