Manual function for finding a median vba? - excel

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

Answer 1

Reinventing the Wheel: VBA Median UDF
Reinventing the wheel
Median
MEDIAN
VarType
Cell error values
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