Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.
Private miNextSummaryColumn As Integer
Sub CalculateWeeklyMinAndMax()
Dim iRow As Integer
Dim iColumn As Integer
Dim dtCalcDateCurrent As Date
Dim dtCalcDateNext As Date
Dim strCellValue As String
Dim dblMin As Double
Dim dblMax As Double
miNextSummaryColumn = 10
iRow = 2 ' skip header
dtCalcDateCurrent = getCalcDate(iRow)
dblMin = 99999
dblMax = 0
Do Until Cells(iRow, 1).Value = ""
' Find min and max for the row
For iColumn = 2 To 7
If iColumn <> 6 Then ' skip for "Volume" data
strCellValue = Cells(iRow, iColumn).Value
If Val(strCellValue) < dblMin Then
dblMin = Val(strCellValue)
End If
If Val(strCellValue) > dblMax Then
dblMax = Val(strCellValue)
End If
End If
Next iColumn
iRow = iRow + 1
dtCalcDateNext = getCalcDate(iRow)
If dtCalcDateNext <> dtCalcDateCurrent Then
' New date so show result in summary sheet
ShowResults dtCalcDateCurrent, dblMin, dblMax
dtCalcDateCurrent = dtCalcDateNext
dblMin = 99999
dblMax = 0
End If
Loop
End Sub
Private Function getCalcDate(RowNumber As Integer)
' assumes that column 7 has this formula: =IF(WEEKDAY(A2) <6,A2+(6-WEEKDAY(A2)), A2+7-MOD(WEEKDAY(A2),7)-1)
' if not, then check the date in the first column of the row and figure out the next Friday
getCalcDate = Cells(RowNumber, 8).Value
End Function
Private Sub ShowResults(CalcDate As Date, MinValue As Double, MaxValue As Double)
Sheets("Summary").Cells(1, miNextSummaryColumn).Value = CalcDate
Sheets("Summary").Cells(2, miNextSummaryColumn).Value = MinValue
Sheets("Summary").Cells(3, miNextSummaryColumn).Value = MaxValue
miNextSummaryColumn = miNextSummaryColumn + 1
End Sub