Here are some UDFs I recently wrote, I believe using the source I cited.
- Jon
-------
Jon Peltier, Microsoft Excel MVP
Peltier Technical Services
Tutorials and Custom Solutions
http://PeltierTech.com/
_______
Option Explicit
Public Function WtAvg(WeightRange As Range, DataRange As Range)
'' Jon Peltier 20 June 2005
'' Weighted Mean
''
'' WeightRange may be any range of one column or one row.
'' DataRange may be any range of one column or one row.
''
'' Errors
'' Range incorrectly sized: #NUM!
'' Sum of weights = 0: #DIV/0!
Dim dTest As Double
If DataRange.Rows.Count <> 1 And DataRange.Columns.Count <> 1 Then
'' Not a single row or column --> #NUM! ERROR
WtAvg = CVErr(xlErrNum)
Exit Function
ElseIf WorksheetFunction.Count(DataRange) <> DataRange.Rows.Count *
DataRange.Columns.Count Then
'' Contains some blank or non-numeric cells --> #NUM! ERROR
WtAvg = CVErr(xlErrNum)
Exit Function
ElseIf WeightRange.Rows.Count <> 1 And WeightRange.Columns.Count <> 1 Then
'' Not a single row or column --> #NUM! ERROR
WtAvg = CVErr(xlErrNum)
Exit Function
ElseIf WorksheetFunction.Count(WeightRange) <> WeightRange.Rows.Count *
WeightRange.Columns.Count Then
'' Contains some blank or non-numeric cells --> #NUM! ERROR
WtAvg = CVErr(xlErrNum)
Exit Function
ElseIf WorksheetFunction.Count(WeightRange) <>
WorksheetFunction.Count(DataRange) Then
'' Unequal range sizes --> #NUM! ERROR
WtAvg = CVErr(xlErrNum)
Exit Function
End If
dTest = WorksheetFunction.SumProduct(WeightRange, DataRange)
If WorksheetFunction.Sum(WeightRange) = 0 Then
'' sum of weights is zero - division by zero
WtAvg = CVErr(xlErrDiv0)
Else
WtAvg = dTest / WorksheetFunction.Sum(WeightRange)
End If
End Function
Public Function WtStD(WeightRange As Range, DataRange As Range)
'' Jon Peltier 20 June 2005
'' Weighted Standard Deviation
''
'' WeightRange may be any range of one column or one row.
'' DataRange may be any range of one column or one row.
''
'' Errors
'' Range incorrectly sized: #NUM!
'' Sum of weights = 0: #DIV/0!
Dim dTest As Double
Dim dSumWts As Double
Dim dSumDatSq As Double
Dim vWtMean As Variant
Dim vrWeights As Variant
Dim vrData As Variant
Dim vWeights() As Double
Dim vData() As Double
Dim lCount As Long
Dim lLoop As Long
Dim lRow As Long
Dim lCol As Long
If DataRange.Rows.Count <> 1 And DataRange.Columns.Count <> 1 Then
'' Not a single row or column --> #NUM! ERROR
WtStD = CVErr(xlErrNum)
Exit Function
ElseIf WorksheetFunction.Count(DataRange) <> DataRange.Rows.Count *
DataRange.Columns.Count Then
'' Contains some blank or non-numeric cells --> #NUM! ERROR
WtStD = CVErr(xlErrNum)
Exit Function
ElseIf WeightRange.Rows.Count <> 1 And WeightRange.Columns.Count <> 1 Then
'' Not a single row or column --> #NUM! ERROR
WtStD = CVErr(xlErrNum)
Exit Function
ElseIf WorksheetFunction.Count(WeightRange) <> WeightRange.Rows.Count *
WeightRange.Columns.Count Then
'' Contains some blank or non-numeric cells --> #NUM! ERROR
WtStD = CVErr(xlErrNum)
Exit Function
ElseIf WorksheetFunction.Count(WeightRange) <>
WorksheetFunction.Count(DataRange) Then
'' Unequal range sizes --> #NUM! ERROR
WtStD = CVErr(xlErrNum)
Exit Function
End If
vWtMean = WtMean(WeightRange, DataRange)
If IsNumeric(vWtMean) Then
lCount = WorksheetFunction.Count(WeightRange)
vrWeights = WeightRange.Value
vrData = DataRange.Value
ReDim vWeights(1 To lCount)
ReDim vData(1 To lCount)
For lRow = LBound(vrWeights, 1) To UBound(vrWeights, 1)
For lCol = LBound(vrWeights, 2) To UBound(vrWeights, 2)
vWeights(lRow * lCol) = vrWeights(lRow, lCol)
Next
Next
For lRow = LBound(vrData, 1) To UBound(vrData, 1)
For lCol = LBound(vrData, 2) To UBound(vrData, 2)
vData(lRow * lCol) = vrData(lRow, lCol)
Next
Next
dSumDatSq = 0
dSumWts = 0
For lLoop = 1 To lCount
dSumDatSq = dSumDatSq + vWeights(lLoop) * (vData(lLoop) - vWtMean) ^ 2
dSumWts = dSumWts + vWeights(lLoop)
Next
If dSumWts = 0 Then
'' sum of weights is zero - division by zero
WtStD = CVErr(xlErrDiv0)
Exit Function
End If
dTest = dSumDatSq / dSumWts
dTest = Sqr(dTest * dSumWts / (dSumWts - 1))
WtStD = dTest
Else
End If
End Function
