weighted average VBA Code

K

kiran66

New Member
Joined
Dec 8, 2020
Messages
13
Office Version
  1. 2019
Platform
  1. Windows
Hii



i have an excel sheet and iam trying to get the weighted averages for the 4 parameters based on their date, if any one can solve my question it would help to my work. i need macros code for calculating weighted average.

upto now i did the simple average by using below code. can you modify this simple average code to weighted average code

Range("Q" & P + 7) = Round(WorksheetFunction.AverageIf(Range("A8:A" & lastRow_R), CDate(xCol2.Item(P)), Range("E8:E" & lastRow_R)), 2)

Range("R" & P + 7) = Round(WorksheetFunction.AverageIf(Range("A8:A" & lastRow_R), CDate(xCol2.Item(P)), Range("F8:F" & lastRow_R)), 2)

Range("S" & P + 7) = Round(WorksheetFunction.AverageIf(Range("A8:A" & lastRow_R), CDate(xCol2.Item(P)), Range("G8:G" & lastRow_R)), 2)

Here

A Column indicates-Date

E,F&G Column Indicates- Parameters

C Column indicates -Weight for respected item

Q,R,S Column indicates - average results to be shown here
 

Attachments

  • Capture11.JPG
    Capture11.JPG
    58.5 KB · Views: 17
Sort by date Sort by votes
This is images for function.
 

Attachments

  • 11111.jpg
    11111.jpg
    35.7 KB · Views: 4
  • 22222.jpg
    22222.jpg
    76.2 KB · Views: 4
Upvote 0

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.
Replace this with your code
And add
VBA Code: 
Dim x as long
to the first of your code
VBA Code: 
 Range("N" & P + 7) = CDate(xCol2.Item(P))
        Range("O" & P + 7) = Round(WorksheetFunction.SumIf(Range("A8:A" & lastRow_R), CDate(xCol2.Item(P)), Range("C8:C" & lastRow_R)), 2)
        x = Application.WorksheetFunction.SumIf(Range("A8:A" & lastRow_R), CDate(xCol2.Item(P)), Range("C8:C" & lastRow_R))
        Range("P" & P + 7) = Round(Evaluate("=sumProduct(--(" & Range("A8:A" & lastRow_R).Address & " = " & CDate(xCol2.Item(P)) & "), " _
        & Range("C8:C" & lastRow_R).Address & " , " & Range("D8:D" & lastRow_R).Address & " )") / x, 2)
        Range("Q" & P + 7) = Round(Evaluate("=sumProduct(--(" & Range("A8:A" & lastRow_R).Address & " = " & CDate(xCol2.Item(P)) & "), " _
        & Range("C8:C" & lastRow_R).Address & " , " & Range("E8:E" & lastRow_R).Address & " )") / x, 2)
        Range("R" & P + 7) = Round(Evaluate("=sumProduct(--(" & Range("A8:A" & lastRow_R).Address & " = " & CDate(xCol2.Item(P)) & "), " _
        & Range("C8:C" & lastRow_R).Address & " , " & Range("F8:F" & lastRow_R).Address & " )") / x, 2)
        Range("S" & P + 7) = Round(Evaluate("=sumProduct(--(" & Range("A8:A" & lastRow_R).Address & " = " & CDate(xCol2.Item(P)) & "), " _
        & Range("C8:C" & lastRow_R).Address & " , " & Range("G8:G" & lastRow_R).Address & " )") / x, 2)
        Range("T" & P + 7) = Round(Evaluate("=sumProduct(--(" & Range("A8:A" & lastRow_R).Address & " = " & CDate(xCol2.Item(P)) & "), " _
        & Range("C8:C" & lastRow_R).Address & " , " & Range("H8:H" & lastRow_R).Address & " )") / x, 2)
 
Upvote 0
i have tried but i am getting result as "0"
can you try the code and repost the excel here please
 
Upvote 0
you can Test Previous code After This Line
VBA Code: 
Range("N" & P + 7) = CDate(xCol2.Item(P))
with
VBA Code: 
Debug.print CDate(xCol2.Item(P))
Debug.print CDate(xCol2.Item(P)).value
Debug.print CDate(xCol2.Item(P)).Address

And see what is result at Immediate window
And then Paste result here.

I don't have CDate(xCol2.Item(P))
and Use this code and it working:
VBA Code: 
Dim Criteria as Range
        Set Criteria = Range("N" & P + 7)
        Range("O" & P + 7) = Round(WorksheetFunction.SumIf(Range("A8:A" & lastRow_R), Criteria, Range("C8:C" & lastRow_R)), 2)
        x = Application.WorksheetFunction.SumIf(Range("A8:A" & lastRow_R), Criteria, Range("C8:C" & lastRow_R))
        Range("P" & P + 7) = Round(Evaluate("=sumProduct(--(" & Range("A8:A" & lastRow_R).Address & " = " & Criteria.address & "), " _
        & Range("C8:C" & lastRow_R).Address & " , " & Range("D8:D" & lastRow_R).Address & " )") / x, 2)
        Range("Q" & P + 7) = Round(Evaluate("=sumProduct(--(" & Range("A8:A" & lastRow_R).Address & " = " & Criteria.address & "), " _
        & Range("C8:C" & lastRow_R).Address & " , " & Range("E8:E" & lastRow_R).Address & " )") / x, 2)
        Range("R" & P + 7) = Round(Evaluate("=sumProduct(--(" & Range("A8:A" & lastRow_R).Address & " = " & Criteria.address & "), " _
        & Range("C8:C" & lastRow_R).Address & " , " & Range("F8:F" & lastRow_R).Address & " )") / x, 2)
        Range("S" & P + 7) = Round(Evaluate("=sumProduct(--(" & Range("A8:A" & lastRow_R).Address & " = " & Criteria.address & "), " _
        & Range("C8:C" & lastRow_R).Address & " , " & Range("G8:G" & lastRow_R).Address & " )") / x, 2)
        Range("T" & P + 7) = Round(Evaluate("=sumProduct(--(" & Range("A8:A" & lastRow_R).Address & " = " & Criteria.address & "), " _
        & Range("C8:C" & lastRow_R).Address & " , " & Range("H8:H" & lastRow_R).Address & " )") / x, 2)
 
Upvote 0
i am posting my excel file can you check it once . i don't no why i am getting zeros in the p,q,r,s,t columns

Google Drive: Sign-in

Access Google Drive with a Google account (for personal use) or Google Workspace account (for business use).
drive.google.com
 
Upvote 0
I Check your Macro.
After Line 370
Between 'MsgBox (xCol2.Count) to Before For V = 8 To lastRow_R
Change code to this:
VBA Code: 
Dim x As Long
        Dim Criteria As Range
        ActiveWorkbook.Worksheets(r).Activate
        lastRow_R = Worksheets(r).Range("A" & Rows.Count).End(xlUp).Row
     For P = 1 To xCol2.Count
        'MsgBox (xCol2.Item(P))
        Range("N" & P + 7) = CDate(xCol2.Item(P))
        Set Criteria = Range("N" & P + 7)
        Range("O" & P + 7) = Round(WorksheetFunction.SumIf(Range("A8:A" & lastRow_R), CDate(xCol2.Item(P)), Range("C8:C" & lastRow_R)), 2)
        x = Application.WorksheetFunction.SumIf(Range("A8:A" & lastRow_R), CDate(xCol2.Item(P)), Range("C8:C" & lastRow_R))
        Range("P" & P + 7) = Round(Evaluate("=sumProduct(--(" & Range("A8:A" & lastRow_R).Address & " = " & Criteria.Address & "), " _
        & Range("C8:C" & lastRow_R).Address & " , " & Range("D8:D" & lastRow_R).Address & " )") / x, 2)
        Range("Q" & P + 7) = Round(Evaluate("=sumProduct(--(" & Range("A8:A" & lastRow_R).Address & " = " & Criteria.Address & "), " _
        & Range("C8:C" & lastRow_R).Address & " , " & Range("E8:E" & lastRow_R).Address & " )") / x, 2)
        Range("R" & P + 7) = Round(Evaluate("=sumProduct(--(" & Range("A8:A" & lastRow_R).Address & " = " & Criteria.Address & "), " _
        & Range("C8:C" & lastRow_R).Address & " , " & Range("F8:F" & lastRow_R).Address & " )") / x, 2)
        Range("S" & P + 7) = Round(Evaluate("=sumProduct(--(" & Range("A8:A" & lastRow_R).Address & " = " & Criteria.Address & "), " _
        & Range("C8:C" & lastRow_R).Address & " , " & Range("G8:G" & lastRow_R).Address & " )") / x, 2)
        Range("T" & P + 7) = Round(Evaluate("=sumProduct(--(" & Range("A8:A" & lastRow_R).Address & " = " & Criteria.Address & "), " _
        & Range("C8:C" & lastRow_R).Address & " , " & Range("H8:H" & lastRow_R).Address & " )") / x, 2)
 
Upvote 0
maabadi said:
I Check your Macro.
After Line 370
Between 'MsgBox (xCol2.Count) to Before For V = 8 To lastRow_R
Change code to this:
VBA Code: 
Dim x As Long
        Dim Criteria As Range
        ActiveWorkbook.Worksheets(r).Activate
        lastRow_R = Worksheets(r).Range("A" & Rows.Count).End(xlUp).Row
     For P = 1 To xCol2.Count
        'MsgBox (xCol2.Item(P))
        Range("N" & P + 7) = CDate(xCol2.Item(P))
        Set Criteria = Range("N" & P + 7)
        Range("O" & P + 7) = Round(WorksheetFunction.SumIf(Range("A8:A" & lastRow_R), CDate(xCol2.Item(P)), Range("C8:C" & lastRow_R)), 2)
        x = Application.WorksheetFunction.SumIf(Range("A8:A" & lastRow_R), CDate(xCol2.Item(P)), Range("C8:C" & lastRow_R))
        Range("P" & P + 7) = Round(Evaluate("=sumProduct(--(" & Range("A8:A" & lastRow_R).Address & " = " & Criteria.Address & "), " _
        & Range("C8:C" & lastRow_R).Address & " , " & Range("D8:D" & lastRow_R).Address & " )") / x, 2)
        Range("Q" & P + 7) = Round(Evaluate("=sumProduct(--(" & Range("A8:A" & lastRow_R).Address & " = " & Criteria.Address & "), " _
        & Range("C8:C" & lastRow_R).Address & " , " & Range("E8:E" & lastRow_R).Address & " )") / x, 2)
        Range("R" & P + 7) = Round(Evaluate("=sumProduct(--(" & Range("A8:A" & lastRow_R).Address & " = " & Criteria.Address & "), " _
        & Range("C8:C" & lastRow_R).Address & " , " & Range("F8:F" & lastRow_R).Address & " )") / x, 2)
        Range("S" & P + 7) = Round(Evaluate("=sumProduct(--(" & Range("A8:A" & lastRow_R).Address & " = " & Criteria.Address & "), " _
        & Range("C8:C" & lastRow_R).Address & " , " & Range("G8:G" & lastRow_R).Address & " )") / x, 2)
        Range("T" & P + 7) = Round(Evaluate("=sumProduct(--(" & Range("A8:A" & lastRow_R).Address & " = " & Criteria.Address & "), " _
        & Range("C8:C" & lastRow_R).Address & " , " & Range("H8:H" & lastRow_R).Address & " )") / x, 2)
Click to expand...
Thank you very much its working fine
 
Upvote 0
maabadi said:
You 're Welcome & thanks for feedback.
Click to expand...
Hii,

can i get the same code in the module 3 line number 53 we are getting average for the total number of quantities here also we need weighted average
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question
to to calculated the weighted average if the inventory above zero
Replies
1
Views
43
dermie_72
D
U
  • Question
Selective weighted average
2
Replies
10
Views
481
offthelip
O
G
  • Solved
Weighted average with SUMIFS
Replies
3
Views
340
AhoyNC
A
K
  • Solved
Update to existing Move data macro
2
Replies
11
Views
260
Alex Blakenburg
A
K
  • Solved
My VBA is only copying the last row of data instead of all the rows
2 3
Replies
24
Views
507
Alex Blakenburg
A

Forum statistics

Threads
1,214,599
Messages
6,120,447
Members
448,966
Latest member
DannyC96

Share this page

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
Back
Top