MS Excel random date and time simulator

Hi Brad..
Sounds smashing....I would apprecaite the VBA is possible and some pointers about what I would need to contruct ahead of tiome work book wise.
I was hoping you'd takle a peak at this...:)

atb
B

byundt ,
Hi..sorry, I misread your comment, and thought mentioned 'You could' write this in a VBA as apposed to me...

I'm not that profecient in XL to do this setting ranges etc..if you can provide a VBA, that would be great or step by step to impliment this through formulas - I would appreciate that too...

Sounds painful..sorry :)
B

Tlogix,
If nobody else solves it before then, I'll revisit your problem in about four hours.
Brad

byundt ,
Thats one of my favorite RTFM comments...
thanks..

Hi B,

The following sub will randomly generate your events.  It assumes you have headers in Sheet1!A1:D1.

Sub GenerateEvents()
   
    Dim Dest As Worksheet
    Dim LastRow As Long
    Dim Counter As Long
    Dim StartDate As Date, EndDate As Date
    Dim MinDuration As Date, MaxDuration As Date
    Dim MinGap As Date, MaxGap As Date
    Dim Current As Date, QuitTime As Date, TimeLeft As Date, Gap As Date, Duration As Date
   
    MinDuration = TimeValue("12:03 am")
    MaxDuration = TimeValue("1:00 am")
    MinGap = TimeValue("12:01 am")
    MaxGap = TimeValue("12:40 am")
   
    Set Dest = ThisWorkbook.Worksheets("Sheet1")
   
    StartDate = InputBox("What is the start date for your event range", "Start Date")
    EndDate = InputBox("What is the end date for your event range", "End Date")
   
    LastRow = Dest.Cells(65536, 1).End(xlUp).Row
    If LastRow > 1 Then Range(Dest.Cells(2, 1), Dest.Cells(65536, 1)).EntireRow.Delete
   
    Current = DateAdd("h", 8, StartDate)
    Counter = 1
   
    Do Until Current >= EndDate
        If Weekday(Current, vbSunday) = 1 Then
            Current = DateAdd("h", 8, Int(Current) + 1)
        ElseIf Weekday(Current, vbSunday) = 7 Then
            Current = DateAdd("h", 8, Int(Current) + 2)
        ElseIf Hour(Current) < 7 Then
            Current = DateAdd("h", 8, Int(Current))
        ElseIf Hour(Current) > 15 Then
            Current = DateAdd("h", 8, Int(Current) + 1)
        Else
            QuitTime = DateAdd("h", 17, Int(Current))
            TimeLeft = QuitTime - Current
            Gap = MinGap + Rnd * (MaxGap - MinGap)
            Current = Current + Gap
            If Gap <= TimeLeft Then
                Duration = MinDuration + Rnd * (MaxDuration - MinDuration)
                Counter = Counter + 1
                With Dest
                    .Cells(Counter, 1) = Counter - 1
                    .Cells(Counter, 2) = Format(Current, "mm/dd/yyyy")
                    .Cells(Counter, 3) = Format(Current, "hh:mm:ss")
                    .Cells(Counter, 4) = Format(Duration, "hh:mm:ss")
                End With
                Current = Current + Duration
            End If
        End If
    Loop
   
End Sub


Regards,

Patrick

B,

Here is an improved routine, with some minor tweaks:

Sub GenerateEvents()
   
    Dim Dest As Worksheet
    Dim LastRow As Long
    Dim Counter As Long
    Dim StartDate As Date, EndDate As Date
    Dim MinDuration As Date, MaxDuration As Date
    Dim MinGap As Date, MaxGap As Date
    Dim Current As Date, QuitTime As Date, TimeLeft As Date, Gap As Date, Duration As Date
   
    MinDuration = TimeValue("12:03 am")
    MaxDuration = TimeValue("1:00 am")
    MinGap = TimeValue("12:01 am")
    MaxGap = TimeValue("12:40 am")
   
    Set Dest = ThisWorkbook.Worksheets("Sheet1")
   
    StartDate = InputBox("What is the start date for your event range", "Start Date")
    EndDate = InputBox("What is the end date for your event range", "End Date")
    EndDate = DateAdd("h", 17, EndDate)
   
    LastRow = Dest.Cells(65536, 1).End(xlUp).Row
    If LastRow > 1 Then Range(Dest.Cells(2, 1), Dest.Cells(65536, 1)).EntireRow.Delete
   
    Current = DateAdd("h", 8, StartDate)
    Counter = 1
   
    Randomize
   
    Do Until Current >= EndDate
        If Weekday(Current, vbSunday) = 1 Then
            Current = DateAdd("h", 8, Int(Current) + 1)
        ElseIf Weekday(Current, vbSunday) = 7 Then
            Current = DateAdd("h", 8, Int(Current) + 2)
        ElseIf Hour(Current) > 16 Then
            Current = DateAdd("h", 8, Int(Current) + 1)
        Else
            QuitTime = DateAdd("h", 17, Int(Current))
            TimeLeft = QuitTime - Current
            Gap = MinGap + Rnd * (MaxGap - MinGap)
            Current = Current + Gap
            If Gap <= TimeLeft Then
                Duration = MinDuration + Rnd * (MaxDuration - MinDuration)
                Counter = Counter + 1
                With Dest
                    .Cells(Counter, 1) = Counter - 1
                    .Cells(Counter, 2) = Format(Current, "mm/dd/yyyy")
                    .Cells(Counter, 3) = Format(Current, "hh:mm:ss")
                    .Cells(Counter, 4) = Format(Duration, "hh:mm:ss")
                End With
                Current = Current + Duration
            End If
        End If
    Loop
   
End Sub


Regards,

Patrick

Here's a sample workbook showing both formula and VBA methods: http://home.mchsi.com/~byundt/RandomTimesQ21441658.xls

Hi Guys..Patrick..thanks for the code..so I ran it  but beyond the 2 input box for start date and end date, I get nothing..
Perhaps you can confirm the requirments for the worksheet, I have a blank sheet and 4 headers in A1-D1, do they need to be named differntly than above example?

With the code in my sample workbook, you put in headers in cells A1:D1, starting values in A2:B2, then let the VBA macro do the rest. If there is existing data, it will be eradicated. Note that the code references named ranges on the worksheet for the min and max duration and interval, plus the start and end of the workday. You set these with the Insert...Names...Define menu item.

Sub RandomWorkweek()
Dim i As Long
Dim temp As Double
Application.ScreenUpdating = False
Rows("3:1000").ClearContents
[C2].FormulaR1C1 = "=RC[-1]+Start+MinInv+(MaxInv-MinInv)*RAND()"
[D2].FormulaR1C1 = "=IF(RC[-1]="""","""",MinDur+(MaxDur-MinDur)*RAND())"
Cells(2, 3).Resize(1, 2).FormulaR1C1 = Cells(2, 3).Resize(1, 2).Value
For i = 3 To 1000
    temp = [MinInv+(MaxInv-MinInv)*RAND()]
    Cells(i, 1).FormulaR1C1 = "=IF(RC[1]="""","""",R[-1]C+1)"
    Cells(i, 2).FormulaR1C1 = "=IF(R[-1]C[1]+R[-1]C[2]-R[-1]C<=Finish,R[-1]C,IF(WEEKDAY(R[-1]C,2)>=5,"""",R[-1]C+1))"
    Cells(i, 3).FormulaR1C1 = "=IF(RC[-1]="""",""""," & temp & "+IF(R[-1]C+R[-1]C[1]-R[-1]C[-1]+" _
        & temp & "<=Finish,R[-1]C+R[-1]C[1],RC[-1]+Start))"
    Cells(i, 4).FormulaR1C1 = "=IF(RC[-1]="""","""",MinDur+(MaxDur-MinDur)*RAND())"
    Cells(i, 1).Resize(1, 4).FormulaR1C1 = Cells(i, 1).Resize(1, 4).Value
    If Cells(i, 1) = "" Then Exit Sub
Next
Application.ScreenUpdating = True
End Sub

Brad

BYundt,
Your example is excellent as always, could'nt workout the temp thing. Also, your example shows one work week..how can I run it for an entire year or more?'
Thanks,

Tlogix,
> Hi Guys..Patrick..thanks for the code..so I ran it  but beyond the 2
> input box for start date and end date, I get nothing..
> Perhaps you can confirm the requirments for the worksheet, I have a
> blank sheet and 4 headers in A1-D1, do they need to be named differntly
> than above example?

That's odd--it works OK for me.  I'll post an example.

Regards,

Patrick

Thanks alot Guys--Brad...awesome...I'm going to go out ona limb here, but if I have a slight incling -you'd probably want this to be done this way...
Thanks as always...

Brad...
When you have a sec..could you kindly comment the lines the vba where I can chnage the variables:
Max interval, duration, hours, days in weeks etc.
Thanks.
B

Tlogix,
I don't know if you noticed, but I updated the sample workbook in my posted link. It's a lot bigger now ~660KB http://home.mchsi.com/~byundt/RandomTimesQ21441658.xls

The min and max interval, starting time, ending time, min and max duration are all set on the worksheet "Using formulas" cells H1:H6. I thought for a simulation you might prefer to avoid tweaking the code all the time.

The restriction to Monday through Friday is done here:
    Cells(i, 2).FormulaR1C1 = "=IF(R[-1]C[1]+R[-1]C[2]-R[-1]C<=Finish,R[-1]C,IF(WEEKDAY(R[-1]C,2)>=5,R[-1]C+3,R[-1]C+1))"

Translated into A1 notation:
=IF(C2+D2-B2<=Finish,B2,IF(WEEKDAY(B2,2)>=5,B2+3,B2+1))

If the previous task ended after 5:00 PM (the value in named range Finish), then test the day of the week. If it is Friday or later, then add 3 to get the next day of the week--in other words the following Monday.

Brad

Brad,

This might be the first time ever I came up with a more robust solution than you did.

Double :)

Regards,

Patrick

Hi Guys

So Patrick  - thanks very much for the solution, I'm not really that qualified to determine the most effective method of impimentation for this solution....I needed a bunch of data and there they were...coool! (duh!)..and ofcourse ol'yoda over there was the first to respond...

What I'd like to do enhance this a little further and post a follow-up question (not sure how to do that..I guess I just post and link here or something) which would skew the randomness of the results:

Assume that events in the range of 3-15mins occur 4/10, 15-30 mins 3/10, 30-45 mins 1.5/10, 45-1hr 1/10, 1hr-2hrs 0.5/10
and then tie this into the current code to generate more simulated data based on my enviroment.

Please give me your feedback on this guys and let me know if I should proceed with new Q.

Regards
B.

B,

Go ahead and post a follow-up question.  Just be very specific about what you need to be produced.

To be safe, it would be wise to post back here with a link to the new question--that way, Brad and I will
be sure to see it.

Patrick

B.
Patrick got me going with his teasing. I've modified my code to use array transfer, and it will post an entire year's worth of random dates and times with about two seconds effort.

And to raise the ante, I've added the requested feature on making the duration vary according to a probability curve. With each turn of the loop, the code picks a random number. It then finds the bin that number belongs to in a cumulative probability based on your brackets. Finally, it chooses a random number within that bin.

As before, the code puts the parameters for the random model on the worksheet where they're easy to tweak. And I liked Patrick's feature of asking for starting and stopping dates, and so incorporated it into the sub. Here's the sample workbook link: http://home.mchsi.com/~byundt/RandomTimesQ21441658.xls and the new code:

Sub RandomWorkweek()
Dim i As Long, j As Long, WkStart As Long, WkEnd As Long, nDur As Long
Dim temp As Double, tempDur As Double, MinDur As Double, MaxDur As Double, MinInv As Double, MaxInv As Double, _
    Start As Double, Finish As Double
Dim StartDate As Date, EndDate As Date
Dim CumDur As Variant, X As Variant, tbDur As Variant

[A2:D65536].ClearContents
Randomize

StartDate = DateValue(Application.InputBox("Please specify a starting date", Type:=2))
EndDate = DateValue(Application.InputBox("Please specify an ending date", Type:=2))
tbDur = Range("tbDur").Value
MinInv = Range("MinInv").Value
MaxInv = Range("MaxInv").Value
Start = Range("Start").Value
Finish = Range("Finish").Value
WkStart = Range("WkStart").Value
WkEnd = Range("WkEnd").Value

nDur = UBound(tbDur)
ReDim CumDur(1 To nDur)
For i = 1 To nDur
    CumDur(i) = tbDur(i, 3)
Next

ReDim X(1 To 65535, 1 To 4)
X(1, 1) = 1
X(1, 2) = StartDate
X(1, 3) = X(1, 2) + Start + MinInv + (MaxInv - MinInv) * Rnd()
X(1, 4) = MinDur + (MaxDur - MinDur) * Rnd()
For i = 2 To 65535
    temp = MinInv + (MaxInv - MinInv) * Rnd()
    tempDur = Rnd()
    j = Application.Match(tempDur, CumDur, 1)
    MinDur = tbDur(j, 1)
    MaxDur = tbDur(j + 1, 1)
    If X(i - 1, 3) + X(i - 1, 4) - X(i - 1, 2) + temp > Finish Then
        If Weekday(X(i - 1, 2), 2) = WkEnd Then
            X(i, 2) = X(i - 1, 2) + 7 - WkEnd + WkStart
        Else
            X(i, 2) = X(i - 1, 2) + 1
        End If
        X(i, 3) = X(i, 2) + Start + temp
    Else
        X(i, 2) = X(i - 1, 2)
        X(i, 3) = X(i - 1, 3) + X(i - 1, 4) + temp
    End If
    X(i, 4) = MinDur + (MaxDur - MinDur) * Rnd()
    X(i, 1) = X(i - 1, 1) + 1
    If X(i, 3) + X(i, 4) > EndDate + Finish Then Exit For
Next

[A2:D65536].Value = X
Columns("B").NumberFormat = "dddd m/d/yyyy"
Range("C:D").NumberFormat = "h:mm:ss"
If i > 20 Then Range(i & ":65536").EntireRow.Delete
i = ActiveSheet.UsedRange.Rows.Count

End Sub

Brad

Hi Guys...
Brad..thanks alot for the above...very nice of you..will run it now ands give feedback...but I really think we should create another Q to be fair.

I will be creating a question with the next part of the requirement...this can be standalone.
Here's the task and I'll link in next post to the question:

I need to hold a memo field in my Db and I would like to create this somewhat randomly in terms of it's length, so here's what I came up with;

I have a block of text with 137 spaces. What if we randomly select a space count (with a skewed probability scale of say 10 levels and then select all the text from the start upto that space count and then copy it to a cell? I would also need something like a unqiue value in each memo field so I can track searches and queries...so something like an alpha permutation on for levels: xxxxaaaa (the 'aaaa' would be the permutated values, the xxxx is to avoid permutation that result in duplicated words in the text line 'code').

// So it would work like this where the text block is:
Patrick never temp the gods of VBA
// and the space count is 4, the text would copied text would be
Patrick never temp the
// and if this were the 3rd random generated text the perm would be
xxxaaac
// the entire copied value would be
Patrick never temp the xxxxaaac
// If we generated a zero space random count and this was the 5th perm, the result would be
xxxxaaae

I was thinking we put the text block in A1 on sheet 1 and generate the results in sheet 2.
The text block will hold a-z, 0-9 and %$!@>?*& chrs etc.

Sounds like a bunch of nonsense..but I need to test from alot of angles and this is what i came up with. Can you guys help? Please let me know.
Regards,
B

OK guys, here's the link:
http://www.experts-exchange.com/Applications/MS_Office/Excel/Q_21443101.html

B,

Kevin seems to have a pretty good handle on the new question, and I must respond to Brad's challenge :)

Here is a version of the sub that will do the revised distribution:

Sub GenerateEvents2()
   
    Dim Dest As Worksheet
    Dim LastRow As Long
    Dim Counter As Long
    Dim StartDate As Date, EndDate As Date
    Dim MinDuration, MaxDuration
    Dim MinGap As Date, MaxGap As Date
    Dim Current As Date, QuitTime As Date, TimeLeft As Date, Gap As Date, Duration As Date
    Dim DurationRnd As Double
    Dim DurationFilter As Long
   
    MinDuration = Array(#12:03:00 AM#, #12:15:00 AM#, #12:30:00 AM#, #12:45:00 AM#, #1:00:00 AM#)
    MaxDuration = Array(#12:15:00 AM#, #12:30:00 AM#, #12:45:00 AM#, #1:00:00 AM#, #2:00:00 AM#)
   
    MinGap = #12:01:00 AM#
    MaxGap = #12:40:00 AM#
   
    Set Dest = ThisWorkbook.Worksheets("Sheet1")
   
    StartDate = InputBox("What is the start date for your event range", "Start Date")
    EndDate = InputBox("What is the end date for your event range", "End Date")
    EndDate = DateAdd("h", 17, EndDate)
   
    LastRow = Dest.Cells(65536, 1).End(xlUp).Row
    If LastRow > 1 Then Range(Dest.Cells(2, 1), Dest.Cells(65536, 1)).EntireRow.Delete
   
    Current = DateAdd("h", 8, StartDate)
    Counter = 1
   
    Randomize
   
    Do Until Current >= EndDate
        If Weekday(Current, vbSunday) = 1 Then
            Current = DateAdd("h", 8, Int(Current) + 1)
        ElseIf Weekday(Current, vbSunday) = 7 Then
            Current = DateAdd("h", 8, Int(Current) + 2)
        ElseIf Hour(Current) > 16 Then
            Current = DateAdd("h", 8, Int(Current) + 1)
        Else
            QuitTime = DateAdd("h", 17, Int(Current))
            TimeLeft = QuitTime - Current
            Gap = MinGap + Rnd * (MaxGap - MinGap)
            Current = Current + Gap
            If Gap <= TimeLeft Then
                DurationRnd = Rnd
                Select Case DurationRnd
                    Case Is < 0.4: DurationFilter = 0
                    Case Is < 0.7: DurationFilter = 1
                    Case Is < 0.85: DurationFilter = 2
                    Case Is < 0.95: DurationFilter = 3
                    Case Else: DurationFilter = 4
                End Select
                Duration = MinDuration(DurationFilter) + Rnd * _
                    (MaxDuration(DurationFilter) - MinDuration(DurationFilter))
                Counter = Counter + 1
                With Dest
                    .Cells(Counter, 1) = Counter - 1
                    .Cells(Counter, 2) = Format(Current, "mm/dd/yyyy")
                    .Cells(Counter, 3) = Format(Current, "hh:mm:ss")
                    .Cells(Counter, 4) = Format(Duration, "hh:mm:ss")
                End With
                Current = Current + Duration
            End If
        End If
    Loop
   
End Sub


Patrick

Hi Brad...
I a slight mod to the code please, is there anyway we can make this repeat 'x' number of times and for each repeat renumerate the events - so the result would be a repeated run on the same ranges with events 1 thru X, 1a thru Xa, 1b thru Xb....based on the number of runs specified?

Much appreciated, please let me know if I can post a question for this.
Thanks,
B

B,
I've uploaded a revised sample workbook showing revised code with the ability to generate up to 256 data sets (if they fit on the worksheet). As before, the control parameters are set on the worksheet, with VBA code doing the random date and time generation. http://home.mchsi.com/~byundt/RandomTimesQ21441658.xls

Sub RandomWorkweek()
Dim i As Long, ii As Long, j As Long, WkStart As Long, WkEnd As Long, nDur As Long, NumSets As Long
Dim temp As Double, tempDur As Double, MinDur As Double, MaxDur As Double, MinInv As Double, MaxInv As Double, _
    Start As Double, Finish As Double
Dim StartDate As Date, EndDate As Date
Dim rg As Range
Dim CumDur As Variant, X As Variant, tbDur As Variant
Dim suffix As String

[A2:D65536].ClearContents
Randomize

On Error Resume Next
StartDate = DateValue(Application.InputBox("Please specify a starting date", Type:=2))
EndDate = DateValue(Application.InputBox("Please specify an ending date", Type:=2))
On Error GoTo 0
If StartDate * EndDate = 0 Then Exit Sub
tbDur = Range("tbDur").Value
MinInv = Range("MinInv").Value
MaxInv = Range("MaxInv").Value
Start = Range("Start").Value
Finish = Range("Finish").Value
WkStart = Range("WkStart").Value
WkEnd = Range("WkEnd").Value
NumSets = Range("NumSets").Value

nDur = UBound(tbDur)
ReDim CumDur(1 To nDur)
For i = 1 To nDur
    CumDur(i) = tbDur(i, 3)
Next

For ii = 1 To NumSets
    If ii > 1 Then suffix = LCase(Mid(Cells(1, ii - 1).Address, 2, InStr(2, Cells(1, ii - 1).Address, "$") - 2))
    ReDim X(1 To 65535, 1 To 4)
    X(1, 1) = 1 & suffix
    X(1, 2) = StartDate
    X(1, 3) = X(1, 2) + Start + MinInv + (MaxInv - MinInv) * Rnd()
    X(1, 4) = MinDur + (MaxDur - MinDur) * Rnd()
    i = 1
    Do Until i = 65535
        i = i + 1
        temp = MinInv + (MaxInv - MinInv) * Rnd()
        tempDur = Rnd()
        j = Application.Match(tempDur, CumDur, 1)
        MinDur = tbDur(j, 1)
        MaxDur = tbDur(j + 1, 1)
        If X(i - 1, 3) + X(i - 1, 4) - X(i - 1, 2) + temp > Finish Then
            If X(i - 1, 2) = EndDate Then Exit Do
            If Weekday(X(i - 1, 2), 2) = WkEnd Then
                X(i, 2) = X(i - 1, 2) + 7 - WkEnd + WkStart
            Else
                X(i, 2) = X(i - 1, 2) + 1
            End If
            X(i, 3) = X(i, 2) + Start + temp
        Else
            X(i, 2) = X(i - 1, 2)
            X(i, 3) = X(i - 1, 3) + X(i - 1, 4) + temp
        End If
        X(i, 4) = MinDur + (MaxDur - MinDur) * Rnd()
        X(i, 1) = Val(X(i - 1, 1)) + 1 & suffix
    Loop
    Set rg = Cells(65536, 1).End(xlUp).Offset(1, 0)
    Range(rg, rg.Offset(i - 1, 3)).Value = X
Next

Columns("B").NumberFormat = "dddd m/d/yyyy"
Range("C:D").NumberFormat = "h:mm:ss"
i = ActiveSheet.UsedRange.Rows.Count

End Sub


Brad

Hi Brad,
Excuse the delay in responding, thanks very much again the additional support - would have like to award points for the above and if there is a way to do so, please let me know.

Best wishes,
B

btw: I posted a question for C# programming - is related to excel..wondering if you have some input....application in C# basically exports a dataset to XLS, I want to have it create a hyperlink for a value (the value is currently a path and file name) it can be clicked in xl to open the file. HAven't had too much luck setting it as a hyperlink.