Skip to main content
2 of 2
fixing my grammar and typos!
JamiRae
  • 111
  • 2

I realize this is an old post, but since it came up in my quest to find a VBA script to calculate the median from a range of values (values in bins) like the original poster asked for, I thought I'd post my solution to share with others.

I am beginner when it comes to VB so its possible there are easier ways to do some of the things I did. I have included comments to document what each step of my script is doing.

You will need to have at least 2 columns in your spreadsheet/range of values. The first column must be the beginning of the range (i.e. if it is for income values with the first two ranges

$0 to $9,9999 $10,000 to $14,9999

Then the first 2 rows of the first colmun should be 0 and 10000). Example in attached screen shot (highlighted portion would be my input). Screenshot of Excel input file. highlighted portion represents the input range

The script prompts for the input range of values. You can have multiple columns of population that you want to get the median for. It will also prompt for the cell you want to put the output, median value(s), into.

here is the script

Sub GetMedian()
'have user select the range for the input data
'the first column must be the number for the beginning of the range
'for the bin
'the second column (can have more than one if doing mulitple areas)
'has the population for that bin
Dim UserRange As Range

Prompt = "Select the input range." & vbCrLf & _
     vbCrLf & "The first column must be the beginning of the " & _
     vbCrLf & "range for the bin. The second column has the  " & _
     vbCrLf & "population for the bin. You can have more than " & _
     vbCrLf & "one column of populations." & _
     vbCrLf
Title = "Select a range"

'Display the Input Box

Set UserRange = Application.InputBox( _
    Prompt:=Prompt, _
    Title:=Title, _
    Default:=Selection.Address, _
    Type:=8) 'Range selection

'get current selected range
Dim myString As String
'myString = Selection.Address
myString = UserRange.Address
'go though the columns
      
'how many columns are in the UserRange?
NoOfCol = Range(myString).Columns.count

'get the output range from the user
Dim OutRange As Range
            
Prompt = "Select a cell for the output" & vbCrLf & _
vbCrLf & "Values for multiple medians will be " & _
vbCrLf & "returned in a row beginning with the " & _
vbCrLf & "selected cell " & _
vbCrLf
'   Display the Input Box
On Error Resume Next
Set OutRange = Application.InputBox( _
    Prompt:=Prompt, _
    Title:=Title, _
    Default:=ActiveCell.Address, _
    Type:=8) 'Range selection
            
'now get to work

'for loop starts with the first population column (2nd in range)
'end is how many pop columns are in the user input range

For col = 2 To NoOfCol
    
    'set range as an array
    Dim myArray() As Variant
    myArray = Range(myString).Value
        
    'get sum of pop and divide by 2 to get halfpoint
    'initialize a total to aggregate values
    popSum = 0
    For i = 1 To UBound(myArray)
        popSum = popSum + myArray(i, col)
    Next
    'MsgBox popSum
    MedianIndex = popSum / 2
    'MsgBox MedianIndex
    'initialize for running total
    runtotal = 0
    
    'step through each row
    For i = 1 To UBound(myArray)
        
        'add the cumulative total pop
        runtotal = runtotal + myArray(i, col)
        'check if the runtotal exceeds the medianIndex
        If runtotal > MedianIndex Then
            'get the cumulative pop for the bin just before we exceeded
            'so subtract the current array value from the current runTotal
            prevTotal = runtotal - myArray(i, col)
            'determine how much into the bin it is to reach the medianIndex
            howMany = MedianIndex - prevTotal
            'get the pop value in the previous bin
            Binpop = myArray(i, col)
            'determine the pct of how far into this bin the medianIndex falls
            pctInto = howMany / Binpop
            'determine the span of the bin
            'and multiply it by the pct into the bin
            MultiSpan = (myArray(i, 1) - myArray(i - 1, 1)) * pctInto
            
            'calculate the median by adding the result to
            'the number for the beginning of hte range
            Median = myArray(i, 1) + MultiSpan
            
            'put the median in the output cell
            OutRange.Offset(0, col - 2).Value = Median
           
            Exit For
        End If
    Next

Next
       
End Sub
JamiRae
  • 111
  • 2