Manual function for finding a median vba?

Question

I'm completely new to VBA and have decided to try recreate excels built in functions. I'm currently trying to create a function that finds the median. for example, it first identifies whether the array is column vector or row vector. i used bubble sort to sort my array in ascending order and then apply a code to find the median value of the sorted array.

However i seem to get a error during the sort, it exists when it tries to swap two values. i get #VALUE error.

Function mymedian(x As Range) As Double

' order array of values asc
' use bubblesort

Dim nr As Integer
Dim nc As Integer
Dim i As Integer
Dim j As Integer
Dim temp As Double
Dim n As Integer

nr = x.Rows.count
nc = x.Columns.count

' col vector

If nc = 1 Then
    
    For i = 2 To nr
        For j = 2 To nr
        
        If x.Cells(j - 1, 1).Value > x.Cells(j, 1).Value Then
        temp = x.Cells(j, 1)
        x.Cells(j, 1).Value = x.Cells(j - 1, 1).Value ' code exists here
        x.Cells(j - 1, 1) = temp
        n = n + 1
        End If
        
        Next j
    Next i
    
Else

' row vector

If nc > 1 Then

    For i = 2 To nc
        For j = 2 To nc
    
        If x.Cells(1, j - 1).Value > x.Cells(1, j).Value Then
        temp = x.Cells(1, j)
        x.Cells(1, j) = x.Cells(1, j - 1).Value
        x.Cells(1, j - 1) = temp
        n = n + 1
        End If
        
        Next j
    Next i
    
End If

End If

As a sub this works fine, does this imply bubble sorts only work as sub routines? i also tried to call the sub within a function, however this wasn't working.

Sub bubblesort()

Dim x As Range
Set x = Selection
Dim nr As Integer
Dim temp As Double

Dim i As Integer
Dim j As Integer

nr = x.Rows.count

    For i = 2 To nr
        For j = 2 To nr
        
        If x.Cells(j - 1, 1).Value > x.Cells(j, 1).Value Then
        temp = x.Cells(j, 1)
        x.Cells(j, 1) = x.Cells(j - 1, 1)
        x.Cells(j - 1, 1) = temp
        End If
        
        Next j
    Next i
    
End Sub
Function middle(x As Range)

Dim n As Integer
Dim mid As Double

Call bubblesort(x)

n = x.Rows.count

mid = x.Cells(n / 2, 1).Value

middle = mid

End Function

A function called by the worksheet cannot change the value of any cell. It can only return a value. You will need to store the values in a variant array and sort those, leaving the data on the sheet alone. — Scott Craner, Aug 01 '22 at 16:48
Thanks for the reply, how should i go by storing values in a worksheet to a variant array? — ManTYK, Aug 01 '22 at 16:57
i don't seem to be having much luck, any chance you can show how i can edit what i have so far so that it gets past the sort ? — ManTYK, Aug 01 '22 at 17:17
Search this site and others, there are many many examples how to bubble sort a variant array. — Scott Craner, Aug 01 '22 at 17:23
Does this answer your question? [VBA array sort function?](https://stackoverflow.com/questions/152319/vba-array-sort-function) — Foxfire And Burns And Burns, Aug 02 '22 at 06:37

VBasic2008 · Answer 1 · 2022-08-03T07:16:25.070

Reinventing the Wheel: VBA Median UDF

Function MyMedian(ByVal SourceRange As Range) As Variant
    Const ProcName As String = "MyMedian"
    On Error GoTo ClearError
    
    ' Calculate the source range number of cells ('dnCount').
    Dim srCount As Long: srCount = SourceRange.Rows.Count
    Dim scCount As Long: scCount = SourceRange.Columns.Count
    Dim dnCount As Long: dnCount = srCount * scCount
    
    Dim sData() As Variant
    
    ' Write the values from the source range to the source array ('sData'),
    ' a 2D one-based array.
    If dnCount = 1 Then ' one cell
        ReDim sData(1 To 1, 1 To 1): sData(1, 1) = SourceRange.Value
    Else ' multiple cells
        sData = SourceRange.Value
    End If
    
    ' Define the destination array('dArr'), a 1D one-based array.
    Dim dArr() As Double: ReDim dArr(1 To dnCount)
    
    Dim sValue As Variant
    Dim sr As Long, sc As Long
    Dim sNumber As Double
    
    Dim dn As Long, n As Long, cn As Long
    Dim dNumber As Double
    
    ' Bubble sort the numbers in the destination array
    ' while reading from the source array.
    For sr = 1 To srCount
        For sc = 1 To scCount
            sValue = sData(sr, sc)
            If VarType(sValue) = vbDouble Then ' the source value is a number
                sNumber = CDbl(sValue)
                dn = dn + 1
                ' Locate a greater number in the destination array.
                For n = 1 To dn - 1
                    dNumber = dArr(n)
                    If dNumber > sNumber Then Exit For
                Next n
                ' Shift the greater destination numbers to the right.
                If n < dn Then
                    For cn = dn To n + 1 Step -1
                        dArr(cn) = dArr(cn - 1)
                    Next cn
                'Else ' the source number is the greatest number; do nothing
                End If
                ' Write the current source number to the destination array.
                dArr(n) = sNumber
            'Else ' the source value is not a number; do nothing
            End If
        Next sc
    Next sr
                    
    ' Mimicking the Excel 'MEDIAN' function to return '#NUM!'
    ' when there is no number in the source range.
    If dn = 0 Then MyMedian = CVErr(xlErrNum): Exit Function
                    
    ' Return the median using the middle destination array value(s).
    If dn Mod 2 = 0 Then ' even
        MyMedian = (dArr(dn / 2) + dArr(dn / 2 + 1)) / 2
    Else ' odd
        MyMedian = dArr(Int(dn / 2) + 1)
    End If

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function

Manual function for finding a median vba?

1 Answers1

Reinventing the Wheel: VBA Median UDF