Hi All,

Occasionally I need a median income or median age value for either an aggregated area or for a population that only has the data available in a distribution table (like in attached screenshot). I created a VBA macro that will run in Excel and calculate the median based on a table range. In the example provided, it is for median household income. I've ran it for known/given median income values and the calculated numbers come up pretty close to those provided in the ACS. The smaller the "bins" (ranges), the better the calculated value.

I have documented each step with comments in the VBA code. I'm not a VBA expert by any means, so there may be better ways to perform some of the steps, but this is works. this is something I've been needing myself for awhile and used to do it with a bunch of formulas in an Excel worksheet. I thought some of you may find it helpful so thought I would share it. I also have a Python version that reads in the data from a CSV file, so if you're interested in that let me know and I can provide it.

Here is the VBA code:

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 'CORRECTED BLOCK 'determine the span of the bin BinSpan 'and multiply it by the pct into the bin BinSpan = (myArray(i + 1, 1) - myArray(i, 1)) MultiSpan = BinSpan * 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