This UDF (user-defined function) implements MEDIANIFS, which acts like SUMIFS or AVERAGEIFS but calculates the median instead

medianifs.vb

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

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.