Maximum 7 Day Average from data range

Calv1

New Member
Joined
Oct 4, 2013
Messages
15
Office Version
  1. 2013
Platform
  1. Windows
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:

Site01/01/202102/01/202103/01/20104/01/202105/01/202106/01/202107/01/202108/01/202109/01/202110/01/2021
Site 1668851223311558899100
Site 255552512141820262830
Site 3444425013722115800500600

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

SiteMax 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
Joined
Dec 23, 2017
Messages
1,976
Office Version
  1. 2010
Platform
  1. Windows
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
 
Solution

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
Joined
Oct 4, 2013
Messages
15
Office Version
  1. 2013
Platform
  1. Windows
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
Joined
Dec 23, 2017
Messages
1,976
Office Version
  1. 2010
Platform
  1. Windows
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
Joined
Oct 4, 2013
Messages
15
Office Version
  1. 2013
Platform
  1. Windows
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
    Capture.PNG
    212.2 KB · Views: 3

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
1,976
Office Version
  1. 2010
Platform
  1. Windows
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
 

Forum statistics

Threads
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.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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
Top