Option Explicit
Sub AThousandAndOneDevilList()
'
' constants
Const ksWS = "Hoja1"
Const ksData = "DataList"
Const ksCycle = "CycleList"
Const ksMin = "MinList"
Const ksMax = "MaxList"
Const kbStartOnFirst1 = True
Const kbEndOnLast1 = True
'
' declarations
Dim ws As Worksheet
Dim rngData As Range, vData As Variant
Dim rngCycle As Range, vCycle As Variant
Dim rngMin As Range, vMin As Variant
Dim rngMax As Range, vMax As Variant
Dim lStart As Long, lEnd As Long, lCount As Long
Dim iDataMin As Integer, iDataMax As Integer
Dim I As Long, J As Long, K As Long
'
' start
Debug.Print Now()
' application
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
' ranges
Set ws = Worksheets(ksWS)
With ws
Set rngData = .Range(ksData)
Set rngCycle = .Range(ksCycle)
Set rngMin = .Range(ksMin)
Set rngMax = .Range(ksMax)
End With
rngMin.ClearContents
rngMax.ClearContents
' arrays
vData = rngData.Value
vCycle = rngCycle.Value
vMin = rngMin.Value
vMax = rngMax.Value
lCount = UBound(vData)
'
' process
I = 1
Do Until I >= lCount
' start of cycle
J = I
If (J = 1) And kbStartOnFirst1 Then
Do Until vCycle(J, 1) = 1 Or J = lCount
J = J + 1
Loop
End If
lStart = J + (J = lCount)
' cycle defaults
iDataMin = vData(J, 1)
iDataMax = vData(J, 1)
' cycle
J = lStart + 1
Do Until vCycle(J, 1) = 1 Or J = lCount
Select Case vData(J, 1)
Case Is < iDataMin
iDataMin = vData(J, 1)
Case Is > iDataMax
iDataMax = vData(J, 1)
End Select
J = J + 1
Loop
If (J <> lCount) Or Not (kbEndOnLast1) Then
lEnd = J - (J <> lCount)
' fill cycle
For K = lStart To lEnd
vMin(K, 1) = Val(iDataMin)
vMax(K, 1) = Val(iDataMax)
Next K
Else
lEnd = lCount
End If
' next cycle
I = lEnd
Loop
'
' end
' arrays
rngMin.Value = vMin
rngMax.Value = vMax
' ranges
Set rngMax = Nothing
Set rngMin = Nothing
Set rngCycle = Nothing
Set rngData = Nothing
Set ws = Nothing
' application
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
' beep
Beep
'
Debug.Print Now()
End Sub
