Option Explicit
Sub RndA1()
RndRange Range("A1")
End Sub
Private Sub RndRange(rr As Range)
Dim Application_Calculation As Long
Application_Calculation = Application.Calculation
Application.Calculation = xlCalculationManual
Dim arr As Variant
arr = GetRndArr()
Set rr = rr.Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
rr.Value = arr
arr = SortArray(rr)
Less15 arr, 15 / 24 / 60
rr.Value = arr
arr = SortArray(rr)
MorningMax arr, 5, 7 / 24, rr
MorningMin arr, 3, 7 / 24, rr, 15 / 24 / 60
DayFill arr, 7 / 24, rr, 15 / 24 / 60
rr.Value = arr
arr = SortArray(rr)
Application.Calculation = Application_Calculation
End Sub
Private Sub DayFill(arr As Variant, dtMorning As Double, rr As Range, deltat As Double)
Dim ym As Long
Dim ye As Long
Dim y1 As Long
Dim d1 As Double
Dim d2 As Double
Do
If Not IsEmpty(arr(UBound(arr, 1), 1)) Then Exit Do
ym = MorningMaxIndex(arr, dtMorning)
For y1 = ym + 1 To UBound(arr, 1) - 1
If arr(y1 + 1, 1) - arr(y1, 1) > 2 * deltat Then
ye = UBound(arr, 1)
d1 = arr(y1, 1) + deltat
If d1 > arr(y1 + 1, 1) Then d1 = arr(y1 + 1, 1)
d2 = arr(y1 + 1, 1) - deltat
If d2 <= d1 Then d2 = d1
arr(ye, 1) = Rnd() * (d2 - d1) + d1
Exit For
End If
Next
rr.Value = arr
arr = SortArray(rr)
DoEvents
Loop
End Sub
Private Sub MorningMin(arr As Variant, nMin As Long, dtMorning As Double, rr As Range, deltat As Double)
Dim ym As Long
Dim ye As Long
Dim y1 As Long
Dim d1 As Double
Dim d2 As Double
Do
ym = MorningMaxIndex(arr, dtMorning)
If ym >= nMin Then Exit Do
If ym = 0 Then
ye = 1
arr(ye, 1) = Rnd() * dtMorning
Else
For y1 = 1 To ym
If arr(y1 + 1, 1) - arr(y1, 1) > 2 * deltat Then
ye = UBound(arr, 1)
d1 = arr(y1, 1) + deltat
If d1 > arr(y1 + 1, 1) Then d1 = arr(y1 + 1, 1)
d2 = arr(y1 + 1, 1) - deltat
If d2 <= d1 Then d2 = d1
arr(ye, 1) = Rnd() * (d2 - d1) + d1
Exit For
End If
Next
End If
rr.Value = arr
arr = SortArray(rr)
DoEvents
Loop
End Sub
Private Sub MorningMax(arr As Variant, nMax As Long, dtMorning As Double, rr As Range)
Dim ym As Long
Dim ye As Long
Do
ym = MorningMaxIndex(arr, dtMorning)
If ym <= nMax Then Exit Do
ye = ym * Rnd() + 1
arr(ye, 1) = Empty
rr.Value = arr
arr = SortArray(rr)
DoEvents
Loop
End Sub
Private Function MorningMaxIndex(arr As Variant, dtMorning As Double)
Dim ym As Long
For ym = 1 To UBound(arr, 1)
If arr(ym, 1) > dtMorning Then Exit For
Next
MorningMaxIndex = ym - 1
End Function
Private Sub Less15(arr As Variant, deltat As Double)
Dim y1 As Long
Dim y2 As Long
For y1 = 1 To UBound(arr, 1) - 1
If Not IsEmpty(arr(y1, 1)) Then
For y2 = y1 + 1 To UBound(arr, 1)
If arr(y2, 1) - arr(y1, 1) < deltat Then
arr(y2, 1) = Empty
Else
Exit For
End If
Next
End If
Next
End Sub
Private Function SortArray(rr As Range) As Variant
Dim st As Sort
Set st = rr.Parent.Sort
With st
.SortFields.Clear
.SortFields.Add Key:=rr, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rr
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
SortArray = rr.Value
End Function
Private Function GetRndArr() As Variant
Randomize
Dim arr As Variant
ReDim arr(1 To 30, 1 To 1)
Dim yy As Long
For yy = 1 To UBound(arr, 1)
arr(yy, 1) = Rnd
Next
GetRndArr = arr
End Function
|
Хотя тогда нечетное число (25) элементов не подходит под эту логику и все равно промежутки в 15-50 минут не укладываются. Поэтому и уточняю. 
