Date Picker Alternative
Date pickers and calendar controls can be an issue in a large audience of Excel application users. The reason is that the necessary Active-X files may not be registered and will cause an application written using mscal.ocx or mscomct2.ocx to fail.
The code below uses VBA date functions to provide a primitive but effective calendar picker for an application that requires the user to select a beginning month for financial projections. After the month is selected, the application then assigns 12 month-end dates, 8 quarter-end dates and 2 year-end dates. These dates are then used to update headers in a number of financial projection worksheets.
The combo-box provides a total of 24 monthly dates from which the user can select the required month for the start of the business projection. These 24 dates are in relation to today's date.
You can also build an elaborate date picker alternative using the method suggested in this link:
Program Code
Option Explicit
Dim strTodaysMonthEndAlpha As String
Dim dteMonthlyDatesForDropDown(1 To 24) As Date
Dim strMonthlyDatesForDropDownAlpha(1 To 24) As String
Dim strMonthlyDatesForWorksheet(1 To 12) As String
Dim strQuarterlyDatesForWorksheet(1 To 8) As String
Dim strYearlyDatesForWorksheet(1 To 5) As String
Dim dteStartingDateForMonthly As Date
Dim dteStartingDateForQuarterly As Date
Dim wkbProjections As Workbook
Dim wksAssumptions As Worksheet
Dim wksIncomeStatement As Worksheet
Dim wksBalanaceSheet As Worksheet
Dim wksCashFlow As Worksheet
Dim wksROI As Worksheet
Dim wksBreakEvenWhatIf As Worksheet
Dim wksIncomeStatementAnnual As Worksheet
Dim wksBalanceSheetAnnual As Worksheet
Dim wksCashFlowAnnual As Worksheet
Dim i As Integer
Dim intStartingMonthIndex As Integer
Private Sub cmdProceedWithLoad_Click()
' *******************************************************************************
' Create Calendar Array Entries For Populating The Worksheets
' *******************************************************************************
intStartingMonthIndex = Me.cmbSelectMonth.ListIndex + 1
dteStartingDateForMonthly = dteMonthlyDatesForDropDown(intStartingMonthIndex)
For i = 1 To 12
strMonthlyDatesForWorksheet(i) = Format(DateSerial(Year(dteStartingDateForMonthly), _
Month(dteStartingDateForMonthly) + i, 0), "Mmmm dd, YYYY")
Next i
For i = 1 To 8
strQuarterlyDatesForWorksheet(i) = Format(DateSerial(Year(dteStartingDateForMonthly), _
Month(dteStartingDateForMonthly) + (3 * i), 0), "Mmmm dd, YYYY")
Next i
For i = 1 To 5
strYearlyDatesForWorksheet(i) = Format(DateSerial(Year(dteStartingDateForMonthly), _
Month(dteStartingDateForMonthly) + (12 * i), 0), "Mmmm dd, YYYY")
Next i
' *******************************************************************************
' Initialize Workbook And Worksheet Variables
' *******************************************************************************
Set wkbProjections = ThisWorkbook
Set wksAssumptions = wkbProjections.Sheets("Assumptions")
Set wksIncomeStatement = wkbProjections.Sheets("Inc Stmt")
Set wksBalanaceSheet = wkbProjections.Sheets("Bal Sheet")
Set wksCashFlow = wkbProjections.Sheets("Cash Flow")
Set wksROI = wkbProjections.Sheets("ROI")
Set wksBreakEvenWhatIf = wkbProjections.Sheets("Brk Ev What If")
Set wksIncomeStatementAnnual = wkbProjections.Sheets("Inc Stmt Annual")
Set wksBalanceSheetAnnual = wkbProjections.Sheets("Bal Sheet Annual")
Set wksCashFlowAnnual = wkbProjections.Sheets("Cash Flow Annual")
' *******************************************************************************
' Update The Worksheet Headers
' *******************************************************************************
Call UpdateWorksheetsWithAllDates(wksAssumptions, 4, 2)
Call UpdateWorksheetsWithAllDates(wksIncomeStatement, 7, 2)
Call UpdateWorksheetsWithAllDates(wksBalanaceSheet, 7, 2)
Call UpdateWorksheetsWithAllDates(wksCashFlow, 6, 2)
Call UpdateWorksheetsWithYearVertical(wksROI, 6, 1)
Call UpdateWorksheetsWithYearHorizontal(wksBreakEvenWhatIf, 6, 2)
Call UpdateWorksheetsWithYearHorizontal(wksBreakEvenWhatIf, 32, 2)
Call UpdateWorksheetsWithYearHorizontal(wksIncomeStatementAnnual, 7, 2)
Call UpdateWorksheetsWithYearHorizontal(wksBalanceSheetAnnual, 7, 2)
Call UpdateWorksheetsWithYearHorizontal(wksCashFlowAnnual, 7, 2)
Unload Me
End Sub
Private Sub UserForm_Initialize()
' **************************************************************************************
' Compute The Dates To Be Used For the Drop Down Date Selector
' **************************************************************************************
strTodaysMonthEndAlpha = Format(DateSerial(Year(Date), Month(Date) + 1, 0), "Mmmm YYYY")
Me.cmbSelectMonth.Clear
For i = 1 To 24
dteMonthlyDatesForDropDown(i) = DateSerial(Year(Date), Month(Date) - 6 + i, 0)
strMonthlyDatesForDropDownAlpha(i) = Format(DateSerial(Year(Date), Month(Date) - 6 + i, 0), "Mmmm YYYY")
Me.cmbSelectMonth.AddItem (strMonthlyDatesForDropDownAlpha(i))
Next i
Me.cmbSelectMonth.Value = strTodaysMonthEndAlpha
End Sub
Private Sub UpdateWorksheetsWithAllDates(SheetToUpdate As Worksheet, RowToUpdate As Long, ColumnToStart As Long)
' *******************************************************************************
' Update Worksheet Header Dates (Format 1)
' *******************************************************************************
Dim lngColumnToUpdate As Long
lngColumnToUpdate = ColumnToStart - 1
For i = 1 To 12
lngColumnToUpdate = lngColumnToUpdate + 1
SheetToUpdate.Cells(RowToUpdate, lngColumnToUpdate).Value = strMonthlyDatesForWorksheet(i)
Next i
For i = 1 To 8
lngColumnToUpdate = lngColumnToUpdate + 1
SheetToUpdate.Cells(RowToUpdate, lngColumnToUpdate).Value = strQuarterlyDatesForWorksheet(i)
Next i
For i = 1 To 2
lngColumnToUpdate = lngColumnToUpdate + 1
SheetToUpdate.Cells(RowToUpdate, lngColumnToUpdate).Value = strYearlyDatesForWorksheet(i)
Next i
End Sub
Private Sub UpdateWorksheetsWithYearHorizontal(SheetToUpdate As Worksheet, RowToUpdate As Long, ColumnToStart As Long)
' *******************************************************************************
' Update Worksheet Header Dates (Format 2)
' *******************************************************************************
Dim lngColumnToUpdate As Long
lngColumnToUpdate = ColumnToStart - 1
For i = 1 To 5
lngColumnToUpdate = lngColumnToUpdate + 1
SheetToUpdate.Cells(RowToUpdate, lngColumnToUpdate).Value = strYearlyDatesForWorksheet(i)
Next i
End Sub
Private Sub UpdateWorksheetsWithYearVertical(SheetToUpdate As Worksheet, RowToStart As Long, ColumnToUpdate As Long)
' *******************************************************************************
' Update Worksheet Header Dates (Format 3)
' *******************************************************************************
Dim lngRowToUpdate As Long
lngRowToUpdate = RowToStart - 1
For i = 1 To 5
lngRowToUpdate = lngRowToUpdate + 1
SheetToUpdate.Cells(lngRowToUpdate, ColumnToUpdate).Value = strYearlyDatesForWorksheet(i)
Next i
End Sub