# 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.'avCriteriaAndRangesPublic 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 `