Print Page | Close Window

GetMedianIF function for Excel

Printed From: Roger's Access Library
Category: Other Download Libraries
Forum Name: Long, Crystal
Forum Description: Access Basics is designed for those of you with a thirst to understand the fundamentals of Access with programming in mind ... whether you realize it or not.
URL: www.rogersaccesslibrary.com/forum/forum_posts.asp?TID=594
Printed Date: 29 Mar 2024 at 9:40am
Software Version: Web Wiz Forums 12.03 - http://www.webwizforums.com


Topic: GetMedianIF function for Excel
Posted By: Crystal Long
Subject: GetMedianIF function for Excel
Date Posted: 04 Jun 2012 at 1:28pm
Excel has functions to Sum and Average for a range using criteria ... but there is no built-in function to get a median value using criteria, so I wrote one.


Function GetMedianIF( _
   pValueRange As Range _
   , pCritColumn As String _
   , pCrit As Variant _
   ) As Variant
'Crystal 120528

   'return the Median value in a range that meets criteria
 
   'example useage in a cell:
   '   =GetMedianIF(E2:E200,"K","Some Name")
   '
   '   E2:E200 is the range to look at to get the median value
   '   K is the column that has the criteria
   '   "Some Name" is the value to compare to. This can be a cell reference.
   '

    Dim arrValues()
    ReDim arrValues(0)
    arrValues(0) = -9999999
  
    Dim nNumValues As Long
  
    Dim nRow As Long _
      , nColValue As Long _
      , nRow1 As Long _
      , nRows As Long
    
    nRow1 = pValueRange.Row
    nRows = pValueRange.Rows.Count
    nColValue = pValueRange.Column

    For nRow = nRow1 To (nRow1 + nRows)
      'see if criteria is met
      If Range(pCritColumn & nRow) = pCrit Then
         If arrValues(0) <> -9999999 Then
            ReDim Preserve arrValues(UBound(arrValues) + 1)
         End If
         arrValues(UBound(arrValues)) = Cells(nRow, nColValue)
      End If
   Next nRow
  
   If arrValues(0) = -9999999 Then
      'uncomment next line if you want to return a message if there is no data
      'GetMedianIF = "no data"
      Exit Function
   End If
 
   If UBound(arrValues) = 0 Then
      'there is only one value
      GetMedianIF = arrValues(0)
      Exit Function
   End If
 
   'sort the array
    SortArray arrValues

   nNumValues = UBound(arrValues) + 1

   'see if the number of values is even or odd
   If nNumValues / 2 = nNumValues \ 2 Then
      'number is even
      'average 2 middle values
      GetMedianIF = (arrValues(nNumValues \ 2 - 1) + arrValues(nNumValues \ 2)) / 2
   Else
      'number of values is odd -- take the middle number
      GetMedianIF = arrValues(nNumValues \ 2 - 1)
   End If

End Function

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Sub SortArray(ByRef varArray() As Variant)
'Sorts a single element array
'based on code written by  Brent Spaulding (datAdrenaline)
'Crystal 120528

    Dim varElement As Variant _
      , nLeft As Long _
      , i As Long
  
    'Bubble sort the array
    If UBound(varArray) > 0 Then
        nLeft = UBound(varArray)
        Do Until nLeft = 0
            For i = LBound(varArray) To nLeft - 1
                If varArray(i) > varArray(i + 1) Then
                    varElement = varArray(i)
                    varArray(i) = varArray(i + 1)
                    varArray(i + 1) = varElement
                End If
            Next i
            nLeft = nLeft - 1
        Loop
    End If
End Sub


Feedback is appreciated, thank you

Warm Regards,
Crystal

Microsoft MVP
remote programming and training

Access Basics by Crystal
http://www.AccessMVP.com/strive4peace - http://www.AccessMVP.com/strive4peace
Free 100-page book that covers essentials in Access

http://www.YouTube.com/LearnAccessByCrystal - http://www.YouTube.com/LearnAccessByCrystal

 *
   (: have an awesome day :)
 *


-------------
Warm Regards,
Crystal
Microsoft MVP
Remote Training & Programming
Let's Connect and Build Together

http://www.AccessMVP.com/strive4peace
http://YouTube.com/LearnAccessByCrystal
~have an awesome day ~



Print Page | Close Window

Forum Software by Web Wiz Forums® version 12.03 - http://www.webwizforums.com
Copyright ©2001-2019 Web Wiz Ltd. - https://www.webwiz.net