Sub ProcessEveryNMinutes()
Dim wsSourceSheet As Worksheet
Dim wsTargetSheet As Worksheet
' Cell containing start time specified for data.
Dim rStartTime As Range
' Value of the start time for data.
Dim dStartTime As Date
' Cell containing first time being processed.
Dim rFirstTime As Range
' Value of first time being processed
Dim dFirstTime As Date
' Range where all times being processed are located.
Dim rTimesToProcess As Range
' For each iteration of results to accumulate totals for Starty Quantity and Amount.
Dim iStartAmount As Long
Dim iStartQty As Long
' Cell range used for looping through ranges
Dim rCell As Range
' Use to keep track of the first and last data rows.
Dim iFirstDataRow As Long
Dim iLastDataRow As Long
' Use to keep track of the count of row times.
Dim iTimeRow As Long
' Range where results are located. Rows in the results range.
Dim rResults As Range
Dim iResultRows As Long
' Cell in target worksheet where results go
Dim rTarget As Range
' Number of minutes between results.
Dim iInterval As Long
' Cell address in results worksheet where results are pasted
Dim sPasteCellAddress As String
' Used when adding difference formulas to specify the previous and current
' amounts. Need cell addresses when adding the formulas.
Dim sPrevAmountAddress As String
Dim sCurrentAmountAddress As String
' Count of results rows in source worksheet.
Dim iResultsRows As Long
' Used to loop through all results rows.
Dim iResultRow As Long
' --------------------------------
' Initializations
' --------------------------------
iInterval = 5
' Worksheet where data is located.
Set wsSourceSheet = ThisWorkbook.Worksheets("Sheet1")
' Worksheet where resuls will be located.
Set wsTargetSheet = ThisWorkbook.Worksheets("Sheet2")
With wsSourceSheet
Set rStartTime = .Range("I2")
Set rFirstTime = .Range("I4")
' Get beginning Quantity and Amount values.
iStartQty = .Range("F2").Value
iStartAmount = .Range("H2").Value
' Get last data row.
iLastDataRow = rStartTime.Offset(10000).End(xlUp).Row
iLastDataRow = iLastDataRow - rFirstTime.Row + 1
' Results header values. Four headers. Ranges to the right of cell rFirstTime.
With rFirstTime
.Offset(, 1).Value = "Time"
.Offset(, 2).Value = "Quantity"
.Offset(, 3).Value = "Amount"
.Offset(, 4).Value = "Difference"
End With
End With 'wsSourceSheet
' Clear all cells in the target workbook (the worksheet where results are located).
wsTargetSheet.Cells.Value = ""
' Location in results worksheet where results are located.
Set rTarget = wsTargetSheet.Range("A3")
dStartTime = rStartTime.Value
' Range where all times are locted.
Set rTimesToProcess = rFirstTime.Resize(iLastDataRow)
' ----------------------------------
' Get row for start time
' ----------------------------------
For Each rCell In rTimesToProcess
iTimeRow = iTimeRow + 1
If rCell.Value = dStartTime Then Exit For
Next rCell
' ---------------------------------------------
' Set 1st Time Cell and Times ranges
' ---------------------------------------------
Set rFirstTime = rFirstTime.Offset(iTimeRow)
Set rTimesToProcess = rFirstTime.Resize(iLastDataRow - iTimeRow)
' -----------------------------------------------------------
' Set first row in results area in source worksheet
' ------------------------------------------------------------
' Put start qty and start amount into first results row in the
' source worksheet. That row is one row above the row for the
' first time to process hence -1 row offset.
With rTimesToProcess.Cells(1)
With .Offset(-1, 1)
.Value = dStartTime
.NumberFormat = "h:m am/pm"
End With
With .Offset(-1, 2)
.Value = iStartQty
.NumberFormat = "#,##0"
End With
With .Offset(-1, 3)
.Value = iStartAmount
.NumberFormat = "#,##0"
End With
.Offset(-1, 4).Value = 0
End With
' ---------------------------------------------------------
' Set results formulas area in source worksheet
' ---------------------------------------------------------
' Put formula to calculate n values for Quantity and Amount into
' results cells in the source worksheet. Use times to process
' columnar data as "anchor" location for results formulas.
For Each rCell In rTimesToProcess
' Clear time values.
rCell.Offset(, 1).Value = ""
' Quantity column is 2 columns over from range rTimesToProcess.
With rCell.Offset(, 2)
.Formula = _
"=SumEveryNValues(" & rFirstTime.Offset(, -2).Address & ", " & rCell.Offset(, -2).Address & ", " & iInterval & ")"
.NumberFormat = "#,##0"
' Get that value then add it to previous sum of Quantities for next iteration.
Application.Calculate
If .Value <> "" Then
.Value = iStartQty + .Value
iStartQty = .Value 'for next iteration
End If
End With
' Amount column is 3 columns over from range rTimesToProcess.
With rCell.Offset(, 3)
.Formula = _
"=SumEveryNValues(" & rFirstTime.Offset(, -1).Address & ", " & rCell.Offset(, -1).Address & ", " & iInterval & ")"
.NumberFormat = "#,##0"
' Get that value then add it to previous sum of Amounts for next iteration.
Application.Calculate
If .Value <> "" Then
.Value = iStartAmount + .Value
iStartAmount = .Value ' for next iteration
End If
End With
Application.Calculate
' Format time
With rCell.Offset(, 3)
If .Value <> "" Then rCell.Offset(, 1).Value = rCell.Value
rCell.Offset(, 1).NumberFormat = "h:m am/pm"
End With
Next rCell
' ----------------------------------------------------
' Convert results formulas to plain values
' ----------------------------------------------------
'
With rTimesToProcess.Cells(1, 2).Resize(iLastDataRow - iTimeRow, 4)
.Value = .Value
End With
' Point range object to range where results were placed.
Set rResults = rTimesToProcess.Cells(1, 2).Resize(iLastDataRow - iTimeRow, 4)
'Debug.Print "rResults = " & rResults.Address
iResultsRows = rResults.Rows.Count
' ----------------------------------------------------------------
' Delete empty rows in results data in soure worksheet
' ----------------------------------------------------------------
' Delete empty cells in results range. Loop backwards
For iResultRow = iResultsRows - 1 To 0 Step -1
If rResults.Cells(1).Offset(iResultRow) = "" _
Then
rResults.Cells(1).Offset(iResultRow).Resize(1, 4).Delete Shift:=xlUp
End If
Next iResultRow
' --------------------------------------------
' Copy results to target worksheet
' --------------------------------------------
' Get first row in results, two below start time cell
iFirstDataRow = rStartTime.Row
' Get last row in results
iLastDataRow = rResults.Cells(1).Offset(10000).End(xlUp).Row
iResultRows = iLastDataRow - iFirstDataRow - 1
' Point rResults range object at the range where results are in source worksheet.
Set rResults = rResults.Cells(1).Offset(-2).Resize(iResultRows, 4)
' Copy the results
rResults.Copy
' Activate the target sheet and cell before paste
wsTargetSheet.Activate
rTarget.Activate
' Clear existing values if any.
rTarget.CurrentRegion.Value = ""
' Put (paste) results into the specified range in target worksheet.
ActiveSheet.Paste
Application.CutCopyMode = False
' --------------------------------------------------------
' Clear results values in the source worksheet
' --------------------------------------------------------
' Clear the results (values) in results in source range worksheet
rResults.Value = ""
' ------------------------------------------------------------
' Add "subtraction" formulas for difference column
' ------------------------------------------------------------
' Set results range to the place where results were pasted.
' rTarget points to the upperleft cell.
Set rResults = rTarget.CurrentRegion
' Loop difference cells in results data in results worksheet and put
' subtraction formulas into them. Format them too.
With rResults.Cells(3, 4)
For Each rCell In .Resize(iResultRows - 2)
With rCell
' Get cell addresses for previous row amount and current row amount.
sPrevAmountAddress = .Offset(-1, -1).Address
sCurrentAmountAddress = .Offset(, -1).Address
' Formula to subtract previous row amount from current row amount to get differnce.
.Formula = "=" & sCurrentAmountAddress & "-" & sPrevAmountAddress
.NumberFormat = "#,##0"
End With
Next rCell
End With
' Activate cell above upperleft results data cell
rResults.Cells(1).Offset(-1).Activate
End Sub
