Instantly share code, notes, and snippets.

Embed
What would you like to do?
This UDF (user-defined function) implements MEDIANIFS, which acts like SUMIFS or AVERAGEIFS but calculates the median instead
Option Explicit
Public Function MEDIANIFS(median_range As Range, ParamArray range_and_criteria_pairs())
Dim lngIdx As Long, lngMedianRowIdx As Long, lngCriteriaIdx As Long
Dim strOperator As String
Dim varThreshold As Variant, varAccumulator() As Variant
ReDim varAccumulator(0)
Dim blnAllMatched As Boolean
'''''''''''''''
'Guard clauses'
'''''''''''''''
'Check for an empty range
If median_range Is Nothing Then
MEDIANIFS = 0
Exit Function
End If
'Check for an uneven number of additional arguments
'(since we rely on range / criteria pairs)
If ((UBound(range_and_criteria_pairs) - LBound(range_and_criteria_pairs)) Mod 2) = 0 Then
MEDIANIFS = 0
Exit Function
End If
'Check for additional range validity (i.e. make sure
'each passed in criteria range has the same number of rows and
'columns as the original range
For lngIdx = LBound(range_and_criteria_pairs) To UBound(range_and_criteria_pairs) Step 2
If range_and_criteria_pairs(lngIdx).Rows.Count <> median_range.Rows.Count Or _
range_and_criteria_pairs(lngIdx).Columns.Count <> median_range.Columns.Count Then
MEDIANIFS = 0
Exit Function
End If
Next lngIdx
'''''''''''''''''''
'Process the range'
'''''''''''''''''''
'Loop through all rows in the target range
For lngMedianRowIdx = 1 To median_range.Rows.Count
'Reset the Match flag, which we will try to flip to True during the Critieria phase
blnAllMatched = False
'Loop through all the range / criteria pairs
For lngCriteriaIdx = LBound(range_and_criteria_pairs) To UBound(range_and_criteria_pairs) Step 2
'Identify the threshold and the operator for use in the criteria phase
Select Case Left(range_and_criteria_pairs(lngCriteriaIdx + 1), 2)
Case Is = "<="
strOperator = "<="
varThreshold = Val(Mid(range_and_criteria_pairs(lngCriteriaIdx + 1), 3))
Case Is = ">="
strOperator = ">="
varThreshold = Val(Mid(range_and_criteria_pairs(lngCriteriaIdx + 1), 3))
'Not equal to (<>) is a little tricky as it could be a number oR a string,
'so we need to check for both of these conditions
Case Is = "<>"
strOperator = "<>"
If IsNumeric(Mid(range_and_criteria_pairs(lngCriteriaIdx + 1), 1)) And Not _
IsEmpty(range_and_criteria_pairs(lngCriteriaIdx + 1)) Then
varThreshold = Val(Mid(range_and_criteria_pairs(lngCriteriaIdx + 1), 3))
Else
varThreshold = UCase(Mid(range_and_criteria_pairs(lngCriteriaIdx + 1), 3))
End If
Case Else '<~ not a 2-character operator, check only the first character
Select Case Left(range_and_criteria_pairs(lngCriteriaIdx + 1), 1)
Case Is = "<"
strOperator = "<"
varThreshold = Val(Mid(range_and_criteria_pairs(lngCriteriaIdx + 1), 2))
Case Is = ">"
strOperator = ">"
varThreshold = Val(Mid(range_and_criteria_pairs(lngCriteriaIdx + 1), 2))
'Equal (=) is a little tricky as it could be a number OR a string,
'so we need to check for both of these conditions
Case Is = "="
strOperator = "="
If IsNumeric(Mid(range_and_criteria_pairs(lngCriteriaIdx + 1), 1)) And Not _
IsEmpty(range_and_criteria_pairs(lngCriteriaIdx + 1)) Then
varThreshold = Val(Mid(range_and_criteria_pairs(lngCriteriaIdx + 1), 2))
Else
varThreshold = UCase(Mid(range_and_criteria_pairs(lngCriteriaIdx + 1), 2))
End If
'For everything else, we are assuming equality (=) but without the
'explicit equal sign. This means the If / Else will be very similar
'to the
Case Else
strOperator = "="
If IsNumeric(range_and_criteria_pairs(lngCriteriaIdx + 1)) And Not _
IsEmpty(range_and_criteria_pairs(lngCriteriaIdx + 1)) Then
varThreshold = range_and_criteria_pairs(lngCriteriaIdx + 1)
Else
varThreshold = UCase(range_and_criteria_pairs(lngCriteriaIdx + 1))
End If
End Select
End Select
'Criteria phase: check each cell in the passed-in ParamArray against the threshold
With range_and_criteria_pairs(lngCriteriaIdx)
'Check the operator (">=", "<=", "<", ">", "<>", and "=") against the cell
Select Case strOperator
Case Is = "<>" '<~ check if cell does not equal the threshold
If UCase(.Cells(lngMedianRowIdx, 1)) <> varThreshold Then
blnAllMatched = True
Else
blnAllMatched = False
End If
Case Is = ">=" '<~ check if cell is greater than or equal to the threshold
If .Cells(lngMedianRowIdx, 1) >= varThreshold Then
blnAllMatched = True
Else
blnAllMatched = False
End If
Case Is = ">" '<~ check if cell is greater than the threshold
If .Cells(lngMedianRowIdx, 1) > varThreshold Then
blnAllMatched = True
Else
blnAllMatched = False
End If
Case Is = "<=" '<~ check if cell is less than or equal to the threshold
If .Cells(lngMedianRowIdx, 1) <= varThreshold Then
blnAllMatched = True
Else
blnAllMatched = False
End If
Case Is = "<" '<~ check if cell is less than the threshold
If .Cells(lngMedianRowIdx, 1) < varThreshold Then
blnAllMatched = True
Else
blnAllMatched = False
End If
Case Else '<~ equal is a special case, could be a number OR a string
'Examine the numeric, non-blank case
If IsNumeric(.Cells(lngMedianRowIdx, 1)) And Not _
IsEmpty(.Cells(lngMedianRowIdx, 1)) Then
If Val(.Cells(lngMedianRowIdx, 1)) = varThreshold Then
blnAllMatched = True
Else
blnAllMatched = False
End If
'Examine the string case
Else
If UCase(CStr(.Cells(lngMedianRowIdx, 1))) = varThreshold Then
blnAllMatched = True
Else
blnAllMatched = False
End If
End If
End Select
End With
'If our flag has not been flipped to True for even a single iteration,
'at least one condition has not been met. As such, the cell will
'NEVER be accumulated!
If Not blnAllMatched Then Exit For
Next lngCriteriaIdx
'Wahoo! If the row passed all criteria (and is numeric),
'add the value to our accumulator
If blnAllMatched Then
With median_range
If IsNumeric(.Cells(lngMedianRowIdx, 1)) And Not IsEmpty(.Cells(lngMedianRowIdx, 1)) Then
varAccumulator(UBound(varAccumulator)) = .Cells(lngMedianRowIdx, 1).Value
ReDim Preserve varAccumulator(UBound(varAccumulator) + 1)
End If
End With
End If
Next lngMedianRowIdx
'Remove the last element from the accumulator, it's empty
ReDim Preserve varAccumulator(UBound(varAccumulator) - 1)
'Calculate the median
MEDIANIFS = WorksheetFunction.Median(varAccumulator)
End Function
Public Sub RegisterUDF()
Dim str As String
str = "Finds median for the cells specified by a given set of conditions or criteria."
Application.MacroOptions Macro:="MEDIANIFS", Description:=str, Category:=4
End Sub
Sub UnregisterUDF()
Application.MacroOptions Macro:="MEDIANIFS", Description:=Empty, Category:=Empty
End Sub
@Merlin999

This comment has been minimized.

Merlin999 commented Mar 3, 2018

Hello Dan
i would like to know how to solve this problem with function MEDIANIFS.
i was trying use your super function MEDIANIFS but there is one problem. It works only on vertical data. I would like to use on horizontally date.. Do you think its possible to create OR do I something wrong?
Thank you very much for you help it is very uselfull.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment