Reworking an old demo database, I came across some code to generate a random date between two supplied dates and thought it could be of use to other.
'---------------------------------------------------------------------------------------
' Procedure : GetRndDate
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Get a random date between 2 dates
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Uses Late Binding, so none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' dtStartDate : Minimum Date value
' dtEndDate : Maximum Date value
'
' Usage:
' ~~~~~~
' dtRnd = GetRndDate(#12/01/2002#, #01/05/2015#)
' Will return a random date between #12/01/2002# and #01/05/2015#
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' **************************************************************************************
' 1 2012-02-07 Initial Release
' 2 2017-02-09 Added check that Start is < to End
' Added Comments to code
' 3 2018-09-20 Updated Copyright
'---------------------------------------------------------------------------------------
Function GetRndDate(dtStartDate As Date, dtEndDate As Date) As Date
On Error GoTo Error_Handler
Dim dtTmp As Date
'Swap the dates if dtStartDate is after dtEndDate
If dtStartDate > dtEndDate Then
dtTmp = dtStartDate
dtStartDate = dtEndDate
dtEndDate = dtTmp
End If
Randomize
GetRndDate = DateAdd("d", Int((DateDiff("d", dtStartDate, dtEndDate) + 1) * Rnd), dtStartDate)
Error_Handler_Exit:
On Error Resume Next
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: GetRndDate" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
Thank you!