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
If you are experiencing a similar issue, please ask a related question
Title | # Comments | Views | Activity |
---|---|---|---|
Tags from access to excel | 3 | 28 | |
Adding Text that self adjusts in a Cell | 8 | 32 | |
Copy value from a certain cell | 5 | 24 | |
excel cannot open the file because the file format or file extension is not valid | 5 | 31 |
Join the community of 500,000 technology professionals and ask your questions.
Connect with top rated Experts
25 Experts available now in Live!