# Maximum 7 Day Average from data range

#### Calv1

##### New Member
Hi,

I have a problem that I can't find a solution for. I have a table that retrieves total production from a site on a given day. This ranges back 3 years.

What I want to be able to find is the maximum 7 day average throughout that period. Any suggestions on the best way to achieve this would be most appreciated. All moving averages I have found do not seem to work dynamically in the way required.

Example table:

 Site 01/01/2021 02/01/2021 03/01/201 04/01/2021 05/01/2021 06/01/2021 07/01/2021 08/01/2021 09/01/2021 10/01/2021 Site 1 66 88 51 22 33 11 55 88 99 100 Site 2 55 55 25 12 14 18 20 26 28 30 Site 3 44 44 250 137 22 11 5 800 500 600

From this, I then have a separate table as such;

 Site Max 7 Day Average Site 1 Site 2 Site 3

What I'd like to do is have a formula, or a macro, that works through the data row by row, calculates the 7 day averages and at the end of it gives me the maximum 7 day average.

Any help or suggestions would be most appreciated.

#### offthelip

##### Well-known Member
for a vba solution try this:
VBA Code:
``````Sub test()
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
inarr = Range(Cells(1, 1), Cells(lastrow, lastcol))
' pick up column and b for the output colummn b gets over written
outarr = Range(Cells(1, 1), Cells(lastrow, 2))
sm = 0
mxsm = 0
For i = 2 To lastrow
' initial 7 days
For jj = 2 To 8
sm = sm + inarr(i, jj)
Next jj
mxsm = sm
For j = 9 To lastcol
' add next  value and subtract oldest value
sm = sm + inarr(i, j) - inarr(i, j - 7)
If sm > mxsm Then
mxsm = sm
'      Cells(i + 10, j) = mxsm
End If
Next j
outarr(i, 2) = mxsm/7
mxsm = 0
sm = 0
Next i
With Worksheets("Sheet2")
outarr(1, 2) = "Max 7 Day Average"
.Range(.Cells(1, 1), .Cells(lastrow, 2)) = outarr
End With
End Sub``````

### Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.

#### Calv1

##### New Member
for a vba solution try this:
VBA Code:
``````Sub test()
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
inarr = Range(Cells(1, 1), Cells(lastrow, lastcol))
' pick up column and b for the output colummn b gets over written
outarr = Range(Cells(1, 1), Cells(lastrow, 2))
sm = 0
mxsm = 0
For i = 2 To lastrow
' initial 7 days
For jj = 2 To 8
sm = sm + inarr(i, jj)
Next jj
mxsm = sm
For j = 9 To lastcol
' add next  value and subtract oldest value
sm = sm + inarr(i, j) - inarr(i, j - 7)
If sm > mxsm Then
mxsm = sm
'      Cells(i + 10, j) = mxsm
End If
Next j
outarr(i, 2) = mxsm/7
mxsm = 0
sm = 0
Next i
With Worksheets("Sheet2")
outarr(1, 2) = "Max 7 Day Average"
.Range(.Cells(1, 1), .Cells(lastrow, 2)) = outarr
End With
End Sub``````
Absolutely perfect. Thanks very much for this. Just tested it and in the main it's working fine.

On some occasions the production data that is pulled through comes through as "No data" or a string as opposed to a number.

Would it be possible to amend the code so that in these instances the values are ignored and move on to the next set of 7 numbers?

#### offthelip

##### Well-known Member
try this ( untested). I have just put a test in to check the values are numeric , if not they should exit the loop
VBA Code:
``````Sub test2()
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
inarr = Range(Cells(1, 1), Cells(lastrow, lastcol))
' pick up column and b for the output colummn b gets over written
outarr = Range(Cells(1, 1), Cells(lastrow, 2))
sm = 0
mxsm = 0
For i = 2 To lastrow
Numt = False
' initial 7 days
For jj = 2 To 8
If Not (IsNumeric(inarr(i, jj))) Then
Numt = True
Exit For
Else
sm = sm + inarr(i, jj)
End If
Next jj
mxsm = sm
For j = 9 To lastcol
If Not (IsNumeric(inarr(i, j))) Or Numt Then Exit For
' add next  value and subtract oldest value
sm = sm + inarr(i, j) - inarr(i, j - 7)
If sm > mxsm Then
mxsm = sm
'      Cells(i + 10, j) = mxsm
End If
Next j
outarr(i, 2) = mxsm / 7
mxsm = 0
sm = 0
Next i
With Worksheets("Sheet2")
outarr(1, 2) = "Max 7 Day Average"
.Range(.Cells(1, 1), .Cells(lastrow, 2)) = outarr
End With
End Sub``````

#### Calv1

##### New Member
Thanks f
try this ( untested). I have just put a test in to check the values are numeric , if not they should exit the loop
VBA Code:
``````Sub test2()
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
inarr = Range(Cells(1, 1), Cells(lastrow, lastcol))
' pick up column and b for the output colummn b gets over written
outarr = Range(Cells(1, 1), Cells(lastrow, 2))
sm = 0
mxsm = 0
For i = 2 To lastrow
Numt = False
' initial 7 days
For jj = 2 To 8
If Not (IsNumeric(inarr(i, jj))) Then
Numt = True
Exit For
Else
sm = sm + inarr(i, jj)
End If
Next jj
mxsm = sm
For j = 9 To lastcol
If Not (IsNumeric(inarr(i, j))) Or Numt Then Exit For
' add next  value and subtract oldest value
sm = sm + inarr(i, j) - inarr(i, j - 7)
If sm > mxsm Then
mxsm = sm
'      Cells(i + 10, j) = mxsm
End If
Next j
outarr(i, 2) = mxsm / 7
mxsm = 0
sm = 0
Next i
With Worksheets("Sheet2")
outarr(1, 2) = "Max 7 Day Average"
.Range(.Cells(1, 1), .Cells(lastrow, 2)) = outarr
End With
End Sub``````
Thanks for taking the time to reply. Unfortunately this doesn't seem to work where there are text values. I get results for those where it's all numbers but not the others. I've attached a small snippet of the data I'm working with in case it helps identify the issue.

Currently working through your code to see if I can work out where the issue is. It's close though. Also surprised at how fast it runs!

#### Attachments

• Capture.PNG
212.2 KB · Views: 3

#### offthelip

##### Well-known Member
that does make it rather more complicatd, try this, I hope I have got the logic correct:
(untested)
VBA Code:
``````Sub test()
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
inarr = Range(Cells(1, 1), Cells(lastrow, lastcol))
' pick up column and b for the output colummn b gets over written
outarr = Range(Cells(1, 1), Cells(lastrow, 2))
sm = 0
mxsm = 0
For i = 2 To lastrow
Vcnt = 0  ' Validity counter
' initial 7 days
For jj = 2 To 8
If Not (IsNumeric(inarr(i, jj))) Then
Vcnt = 0
sm = 0
Else
sm = sm + inarr(i, jj)
Vcnt = Vcnt + 1
End If
Next jj
If Vcnt >= 7 Then
mxsm = sm
End If
For j = 9 To lastcol
If Not (IsNumeric(inarr(i, j))) Then
Vcnt = 0
sm = 0
Else
Vcnt = Vcnt + 1
If Vcnt < 7 Then
sm = sm + inarr(i, j)
' add next  value and subtract oldest value
Else
sm = sm + inarr(i, j) - inarr(i, j - 7)
If sm > mxsm Then
mxsm = sm
End If
'      Cells(i + 10, j) = mxsm
End If
End If
Next j
outarr(i, 2) = mxsm / 7
mxsm = 0
sm = 0
Next i
With Worksheets("Sheet2")
outarr(1, 2) = "Max 7 Day Average"
.Range(.Cells(1, 1), .Cells(lastrow, 2)) = outarr
End With
End Sub``````

Replies
2
Views
101
Replies
4
Views
81
Replies
5
Views
126
Replies
6
Views
117
Replies
3
Views
84

1,141,768
Messages
5,708,416
Members
421,567
Latest member
vicpinto1970

### We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.

### Which adblocker are you using?

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

### Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

### Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back