MEDIANIFS
Returns the median for a list of numbers that satisfy multiple criteria.
Remarks
* You can use the MEDIAN function to return the median value in a list or array of numbers.
* For instructions on how to add a function to a workbook refer to the page under Inserting Functions
'rgeMedianRange - The range of corresponding values you want the median of.
'avCriteriaAndRanges
Public Function MEDIANIFS(ByVal rgeMedianRange As Range, _
ParamArray avCriteriaAndRanges() As Variant) As Variant
Dim avCriterias() As Range
Dim asCriterias() As String
Dim icriteriacount As Integer
Dim rgeCriteria As Range
Dim sCriteria As String
Dim iitemcount As Integer
Dim lrowno As Long
Dim lmatch As Long
Dim arsngvalues() As Single
Dim sngmedian As Single
Dim bsorted As Boolean
Dim vcellvalue As Variant
If UBound(avCriteriaAndRanges, 1) Mod 2 > 0 Then
'not the correct amount of arguments
End If
ReDim avCriterias(UBound(avCriteriaAndRanges, 1))
ReDim asCriterias(UBound(avCriteriaAndRanges, 1))
icriteriacount = 1
For iitemcount = 0 To UBound(avCriteriaAndRanges, 1) Step 2
If TypeName(avCriteriaAndRanges(iitemcount)) = "Range" Then
sCriteria = CStr(avCriteriaAndRanges(iitemcount).Value)
End If
If TypeName(avCriteriaAndRanges(iitemcount)) = "Boolean" Then
sCriteria = CStr(CBool(avCriteriaAndRanges(iitemcount)))
End If
If TypeName(avCriteriaAndRanges(iitemcount)) = "String" Then
sCriteria = CStr(avCriteriaAndRanges(iitemcount))
End If
If TypeName(avCriteriaAndRanges(iitemcount + 1)) = "Range" Then
Set rgeCriteria = avCriteriaAndRanges(iitemcount + 1)
End If
Set avCriterias(icriteriacount) = rgeCriteria
asCriterias(icriteriacount) = sCriteria
icriteriacount = icriteriacount + 1
Next iitemcount
ReDim Preserve avCriterias(icriteriacount - 1)
ReDim Preserve asCriterias(icriteriacount - 1)
'must all have the same number of rows
ReDim arsngvalues(avCriterias(1).Rows.Count)
For lrowno = 1 To rgeCriteria.Rows.Count
vcellvalue = rgeCriteria.Parent.Cells(rgeCriteria.Row + lrowno - 1, rgeMedianRange.Column).Value
If Row_MatchesAllCriteria(lrowno, avCriterias, asCriterias) = True And _
IsNumeric(vcellvalue) = True Then
lmatch = lmatch + 1
arsngvalues(lmatch) = rgeMedianRange.Parent.Cells(rgeMedianRange.Row + lrowno - 1, rgeMedianRange.Column).Value
End If
If lmatch > 0 And IsEmpty(vcellvalue) = True Then Exit For
Next lrowno
ReDim Preserve arsngvalues(lmatch)
Do
bsorted = True
For lrowno = 2 To lmatch
If arsngvalues(lrowno - 1) > arsngvalues(lrowno) Then
sngmedian = arsngvalues(lrowno - 1)
arsngvalues(lrowno - 1) = arsngvalues(lrowno)
arsngvalues(lrowno) = sngmedian
bsorted = False
End If
Next lrowno
Loop Until bsorted = True
If lmatch Mod 2 = 0 Then MEDIAN_IFS = (arsngvalues(CInt(lmatch / 2)) + arsngvalues(1 + CInt(lmatch / 2))) / 2
If lmatch Mod 2 = 1 Then MEDIAN_IFS = arsngvalues((lmatch + 1) / 2)
End Function
Public Function Row_MatchesAllCriteria(ByVal lrowno As Long, _
ByVal vArrayCriteria As Variant, _
ByVal sArrayCriteria As Variant) As Boolean
Dim avCriterias() As Range
Dim asCriterias() As String
Dim rgeCriteria As Range
Dim sCriteria As String
Dim iitemcount As Integer
Dim bmatch As Boolean
Dim iconditioncolno As Integer
Dim icriteriacount As Integer
ReDim avCriterias(UBound(vArrayCriteria, 1))
ReDim asCriterias(UBound(sArrayCriteria, 1))
For iitemcount = 1 To UBound(vArrayCriteria, 1)
If TypeName(vArrayCriteria(iitemcount)) = "Range" Then
Set rgeCriteria = vArrayCriteria(iitemcount)
End If
If TypeName(sArrayCriteria(iitemcount)) = "String" Then
sCriteria = CStr(sArrayCriteria(iitemcount))
End If
Set avCriterias(iitemcount) = rgeCriteria
asCriterias(iitemcount) = sCriteria
Next iitemcount
bmatch = True
For icriteriacount = 1 To UBound(avCriterias, 1)
iconditioncolno = avCriterias(icriteriacount).Column
Dim tempCondition As String
Dim tempCellValue As String
tempCondition = asCriterias(icriteriacount)
'check the symbol and add the default equals if not there
If ((Left(tempCondition, 1) <> "<") And _
(Left(tempCondition, 1) <> ">")) Then
If (Left(tempCondition, 1) <> "=") Then tempCondition = "=" & tempCondition
End If
tempCellValue = avCriterias(icriteriacount).Parent.Cells(avCriterias(icriteriacount).Row + lrowno - 1, iconditioncolno).Value
If (Criteria_Check(tempCondition, tempCellValue) = True) Then
Else
bmatch = False
End If
Next icriteriacount
Row_MatchesAllCriteria = bmatch
End Function
Public Function Criteria_Check(ByVal sCriteria As String, _
ByVal sValue As String) As Boolean
If ((InStr(sCriteria, "*") > 0) And (InStr(sCriteria, "~*") = 0)) Or _
((InStr(sCriteria, "?") > 0) And (InStr(sCriteria, "~?") = 0)) Then
If (Left(sCriteria, 1) = "=") Then sCriteria = Right(sCriteria, Len(sCriteria) - 1)
Criteria_Check = (sValue Like sCriteria)
Exit Function
End If
If (Left(sCriteria, 1) = "=") Then
Criteria_Check = (sValue = Right(sCriteria, Len(sCriteria) - 1))
Exit Function
End If
If (Left(sCriteria, 1) = ">") And _
(Left(sCriteria, 2) <> ">=") Then
Criteria_Check = (CSng(sValue) > CSng(Right(sCriteria, Len(sCriteria) - 1)))
Exit Function
End If
If (Left(sCriteria, 1) = "<") And _
(Left(sCriteria, 2) <> "<=") And (Left(sCriteria, 2) <> "<>") Then
Criteria_Check = (CSng(sValue) < CSng(Right(sCriteria, Len(sCriteria) - 1)))
Exit Function
End If
If (Left(sCriteria, 2) = ">=") Then
Criteria_Check = (CSng(sValue) >= CSng(Right(sCriteria, Len(sCriteria) - 2)))
Exit Function
End If
If (Left(sCriteria, 2) = "<=") Then
Criteria_Check = (CSng(sValue) <= CSng(Right(sCriteria, Len(sCriteria) - 2)))
Exit Function
End If
If (Left(sCriteria, 2) = "<>") Then
Criteria_Check = (CSng(sValue) <> CSng(Right(sCriteria, Len(sCriteria) - 2)))
Exit Function
End If
Criteria_Check = sValue Like sCriteria
End Function
'rgeCriteria - The range of cells containing the criteria you want to check.
'sCriteria - The criteria value you want to match.
'rgeMedianRange - The range of corresponding values you want the median of.
Public Function MEDIANIF(ByVal rgeCriteria As Range, _
ByVal sCriteria As String, _
ByVal rgeMedianRange As Range) As Single
Dim iconditioncolno As Integer
Dim inumberscolno As Integer
Dim lrowno As Long
Dim lmatch As Long
Dim arsngvalues() As Single
Dim sngmedian As Single
Dim bsorted As Boolean
Dim vcellvalue As Variant
iconditioncolno = rgeCriteria.Column
inumberscolno = rgeMedianRange.Column
ReDim arsngvalues(rgeCriteria.Rows.Count)
For lrowno = 1 To rgeCriteria.Rows.Count
vcellvalue = rgeCriteria.Parent.Cells(rgeCriteria.Row + lrowno - 1, inumberscolno).Value
If rgeCriteria.Parent.Cells(rgeCriteria.Row + lrowno - 1, iconditioncolno).Value = sCriteria And _
IsNumeric(vcellvalue) = True Then
lmatch = lmatch + 1
arsngvalues(lmatch) = rgeCriteria.Parent.Cells(rgeCriteria.Row + lrowno - 1, inumberscolno).Value
End If
If lmatch > 0 And IsEmpty(vcellvalue) = True Then Exit For
Next lrowno
ReDim Preserve arsngvalues(lmatch)
Do
bsorted = True
For lrowno = 2 To lmatch
If arsngvalues(lrowno - 1) > arsngvalues(lrowno) Then
sngmedian = arsngvalues(lrowno - 1)
arsngvalues(lrowno - 1) = arsngvalues(lrowno)
arsngvalues(lrowno) = sngmedian
bsorted = False
End If
Next lrowno
Loop Until bsorted = True
If lmatch Mod 2 = 0 Then MEDIANIF = (arsngvalues(CInt(lmatch / 2)) + arsngvalues(1 + CInt(lmatch / 2))) / 2
If lmatch Mod 2 = 1 Then MEDIANIF = arsngvalues((lmatch + 1) / 2)
End Function
© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited TopPrevNext