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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
This comment has been minimized.
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.