Calculating weighted averges betwwn different time periods

  • Thread starter Thread starter nagaraj45
  • Start date Start date
N

nagaraj45

I have the follwing worksheet"

Date Rate Qty
2:06:56 PM 199.5 116
2:06:49 PM 199.5 343
2:06:40 PM 199.5 226
2:06:28 PM 199.5 48
2:06:20 PM 199.4 162
2:06:11 PM 199.5 95
2:06:04 PM 199.4 449
2:05:58 PM 199.6 1488
2:05:40 PM 199.5 9
2:05:40 PM 199.5 9
2:05:37 PM 199.4 161
2:05:28 PM 199.6 101
2:05:23 PM 199.35 4605
2:05:15 PM 199.5 5926
2:05:06 PM 199.6 217
2:04:57 PM 199.6 3
2:04:52 PM 199.75 207
2:04:44 PM 199.6 4180
2:04:39 PM 199.8 75
2:04:32 PM 199.55 2277
2:04:20 PM 199.7 194
2:04:13 PM 199.5 4280
2:04:09 PM 199.7 780
2:03:58 PM 199.7 108
2:03:49 PM 199.7 10
2:03:46 PM 199.7 3006
2:03:32 PM 199.75 1471
2:03:22 PM 199.6 217
2:03:16 PM 199.7 815
2:03:10 PM 199.7 271
2:03:04 PM 199.6 400
2:02:54 PM 199.75 50
2:02:48 PM 199.75 168
2:02:39 PM 199.75 210
2:02:24 PM 199.75 257
2:02:19 PM 199.5 1067
2:02:12 PM 199.85 2055
2:01:59 PM 199.55 2
2:01:53 PM 199.95 114
2:01:48 PM 199.4 4544
2:01:43 PM 200 143
2:01:35 PM 200 736
2:01:28 PM 199.9 212
2:01:20 PM 199.8 325
2:01:12 PM 199.5 10100
2:01:03 PM 199.8 2873
2:00:58 PM 199.8 492
2:00:44 PM 200.2 551
2:00:37 PM 199.85 2965
2:00:28 PM 199.85 1429
2:00:20 PM 199.65 474
2:00:13 PM 199.9 2226
2:00:02 PM 200 168
1:59:57 PM 199.65 33
1:59:50 PM 199.6 47

I would like to calculate the weighed average rate( rate*qty/total qty
durig a period) for different periods say 2.00 pm to 2.01 pm, 2.01pm
to 2.02 pm etc. Is there a way to do this by using
database(dsum,daverage) functions. What will be the content of the
criterion range?

Or is there any other way of solving this. Thanks ln advance
 
One other way using this macro.

Sub listUnique()
Dim col As Integer, startR As Integer, r As Long
Dim CuProd As Double, CuQty As Long, lr As Long, l As Long
Dim row As Long, i As Long, TCol As Integer, lst

Set rng = Selection
l = Selection.Rows.Count
r = ActiveCell.row - 1: startR = ActiveCell.row: TCol = ActiveCell.Column
lr = startR + l - 1: col = TCol + 4: row = r

For i = startR To lr
d = Int(Cells(i, TCol) * 1440) * 1 / 1440
Set lst = Range(Cells(startR, col), Cells(row, col))
x = Application.Match(d, lst, 0)
If IsError(x) Then
row = row + 1
Cells(row, col) = d
CuProd = Cells(i, TCol + 1) * Cells(i, TCol + 2)
CuQty = Cells(i, TCol + 2)
Cells(row, col + 1) = Cells(i, 2)
Else
CuQty = CuQty + Cells(i, TCol + 2)
CuProd = CuProd + Cells(i, TCol + 1) * Cells(i, TCol + 2)
Cells(row, col + 1).Value = Application.Round(CuProd / CuQty, 3)
End If
Next i

End Sub

Copy the macro into a VB Module, Alt + F11, Insert module copy the code and
return to workbook.

Select the dates and run the code.

Assumptions: there are three columns of data only - the times in minutes and
the weighted rates are listed in columns E and F.

If therer are more than 3 columns in the data you need to alter the number
of columns to offset the calculations. On your data the following results are
given.

Time Col
2:06 PM 199.458
2:05 PM 199.458
2:04 PM 199.567
2:03 PM 199.702
2:02 PM 199.734
2:01 PM 199.557
2:00 PM 199.875
1:59 PM 199.621

Regards
Peter
 
One other way using this macro.

Sub listUnique()
Dim col As Integer, startR As Integer, r As Long
Dim CuProd As Double, CuQty As Long, lr As Long, l As Long
Dim row As Long, i As Long, TCol As Integer, lst

Set rng = Selection
l = Selection.Rows.Count
r = ActiveCell.row - 1: startR = ActiveCell.row: TCol = ActiveCell.Column
lr = startR + l - 1: col = TCol + 4: row = r

For i = startR To lr
  d = Int(Cells(i, TCol) * 1440) * 1 / 1440
  Set lst = Range(Cells(startR, col), Cells(row, col))
    x = Application.Match(d, lst, 0)
    If IsError(x) Then
    row = row + 1
      Cells(row, col) = d
     CuProd = Cells(i, TCol + 1) * Cells(i, TCol + 2)
     CuQty = Cells(i, TCol + 2)
      Cells(row, col + 1) = Cells(i, 2)
      Else
        CuQty = CuQty + Cells(i, TCol + 2)
        CuProd = CuProd + Cells(i, TCol + 1) * Cells(i, TCol + 2)
        Cells(row, col + 1).Value = Application.Round(CuProd / CuQty, 3)
    End If
Next i

End Sub

Copy the macro into a VB Module, Alt + F11, Insert module copy the code and
return to workbook.

Select the dates and run the code.

Assumptions: there are three columns of data only - the times in minutes and
the weighted rates are listed in columns E and F.

If therer are more than 3 columns in the data you need to alter the number
of columns to offset the calculations. On your data the following results are
given.

Time    Col
2:06 PM 199.458
2:05 PM 199.458
2:04 PM 199.567
2:03 PM 199.702
2:02 PM 199.734
2:01 PM 199.557
2:00 PM 199.875
1:59 PM 199.621

Regards
Peter








- Show quoted text -

I copied the macro and it works fine though I am unable to get into
the nitty gritty of the code as I am new to VBA. On running the macro
i am able to get the the weighted average rates for every minute of
the selected range. Is there a way to get the total quanity during
every period? Also If it is not asking for too much, is it possible to
change the duration, say every 5 minutes or every 10 minutes and get
the total quantity and weighted averages during such periods?

Thanks as always.
 
I'll have to get back to you - but do you want to be able to change the
number of minutes each time you run the macro?

Peter

"> I copied the macro and it works fine though I am unable to get into
 
Ok I have rewritten the macro and it works for 1 or two minutes. You will be
prompted to enter the number of minutes you wish to analyse. It will work
whenever the period you choose divide neatly into the numer of minutes in the
day i.e. 1440.

There may be a problem, not tested, where the number is a prime of seven or
above or multiples of the a prime e.g. 14, 22. You might like to test this
with more data and let me know, I'm curious to find out. the revised code is:

Sub WghtdAve2()
Dim col As Integer, startR As Integer, r As Long
Dim CuProd As Double, CuQty As Long, lr As Long, l As Long
Dim row As Long, i As Long, TCol As Integer, lst
Dim d, Header, myMins As Integer, myrate As Double

Const MINUTESPERDAY As Integer = 1440
myMins = InputBox("Enter Minutes to Analyse", "Specify Time Period", 2, 100,
100)
myrate = MINUTESPERDAY / myMins
Set rng = Selection
l = Selection.Rows.Count
r = ActiveCell.row - 1: startR = ActiveCell.row: TCol = ActiveCell.Column
lr = startR + l - 1: col = TCol + 4: row = r
Header = Array("Time", "wRate", "Tot Q")
Cells(1, col).CurrentRegion.ClearContents
Range(Cells(1, col), Cells(1, col + 2)) = Header
Application.ScreenUpdating = False
For i = startR To lr
d = Int(Cells(i, TCol) * myrate) * 1 / myrate
Set lst = Range(Cells(startR, col), Cells(row, col))
x = Application.Match(d, lst, 0)
If IsError(x) Then
row = row + 1
Cells(row, col) = d
CuProd = Cells(i, TCol + 1) * Cells(i, TCol + 2)
CuQty = Cells(i, TCol + 2)
Cells(row, col + 1) = Cells(i, 2)
Cells(row, col + 2) = CuQty
Else
CuQty = CuQty + Cells(i, TCol + 2)
CuProd = CuProd + Cells(i, TCol + 1) * Cells(i, TCol + 2)
Cells(row, col + 1).Value = Application.Round(CuProd / CuQty, 3)
Cells(row, col + 2) = CuQty
End If
Next i
Cells(1, col).Select
Application.ScreenUpdating = True
End Sub

Look forward to hearing about primes!
Regards
Peter
 
Back
Top