For some reason the code above works for all date types except for WeekDays. This new code only works for weekdays:
Sub myWeekDays()
'Standard module code, like: Module1.
Dim datMyStartDate As Date, datMyNewDate As Date
Dim lngNextRow&, lngIntervalPeriod&, lngNumOfDatesToList&, lngColNum&, lngMyBot&
Dim strInCellDropDownSheetName$, strTableOfDatesDataSheetName$
Dim strDtIntervalType$, strCellToGetTheDropDownList$, strTableOfDatesColumn$
Dim strDateTableColumn$, strNameOfThisDateList$, strListLocation$
Dim rngMyUsedRng As Object, cell As Object
Dim myDt As Variant
'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 = #8/1/2007# 'The Date to start the Date List With!
lngIntervalPeriod = 1 'How many of the Interval Type to space dates by!
lngNumOfDatesToList = 31 '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("w", lngIntervalPeriod, datMyStartDate)
.Range(strTableOfDatesColumn & lngNextRow).Value = datMyNewDate
datMyStartDate = datMyNewDate
Next lngNextRow
.Columns(strDateTableColumn).Columns.AutoFit
Set rngMyUsedRng = .Range(Cells(1, .Columns(strDateTableColumn).Column), _
Cells(lngNumOfDatesToList, .Columns(strDateTableColumn).Column))
For Each cell In rngMyUsedRng
If cell.Value = "" Then GoTo myNext
myDt = Format(cell.Value, "short date")
If (Application.WorksheetFunction.Weekday(myDt, 2) = 6 Or _
Application.WorksheetFunction.Weekday(myDt, 2) = 7) Then _
cell.Clear
myNext:
Next cell
For Each cell In rngMyUsedRng
If cell.Value = "" Then cell.EntireRow.Delete
Next cell
For Each cell In rngMyUsedRng
If cell.Value = "" Then cell.EntireRow.Delete
Next cell
lngColNum = Range(strTableOfDatesColumn & ":" & strTableOfDatesColumn).Column
lngMyBot = Range(strTableOfDatesColumn & "65536").End(xlUp).Row
strMyListLocation = "=" & strTableOfDatesDataSheetName & _
"!R1C" & lngColNum & ":R" & lngMyBot & "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
