All smooths in this post
Here are all smooths in this post:

The line "smooth" is the one derived in the question. The lines for "smooth2" and "smooth3" were the motivation to derive the Quantile regression solution, "smoothQR". The speed-ups are around 7 and 4.5 times respectively. (See the related discussion in Rahul's answer.)
Simple modifications of question's code
Switching Mean
and Median
makes the computations ~ 7 times faster on my laptop. (The rationale for doing that is that finding the median is slower than finding the mean.)
SeedRandom[0];
x = RandomReal[1, 5000];
AbsoluteTiming[
smooth = Mean@Table[MedianFilter[x, n], {n, 500, 900, 5}];
](* original code in the question *)
(* {8.44073, Null} *)
ListLinePlot[smooth]

Mean
and Median
switched around:
AbsoluteTiming[
smooth2 = Median@Table[MeanFilter[x, n], {n, 500, 900, 5}];
]
(* {1.31114, Null} *)
ListLinePlot[smooth2]

Or using just Mean
:
AbsoluteTiming[
smooth3 = Mean@Table[MeanFilter[x, n], {n, 500, 900, 5}];
]
(* {1.41859, Null} *)
ListLinePlot[smooth3]

Using Quantile regression
Here is a more complicated way to speed up things together with some error measurements.
Select parameters.
Apply MedianFilter
as in the question but with larger step between the min and max window sizes.
Find the mean or median of the obtained array. (We get a vector as a result.)
Apply quantile regression with B-spline basis over a sample of the points from step 3.
Using the found regression quantile function extract points.
Plot and measure errors.
The process of steps 2-5 is around 3 to 5 times faster on my laptop than the original code in the question and with a reasonable max relative error, less than 0.5%.
{a, b, step} = {500, 900, 5};
{factor, sampleSize, nKnots} = {16, 800, 25};
AbsoluteTiming[
smooth = Mean@Table[MedianFilter[x, n], {n, a, b, s}];
]
(* {8.62565, Null} *)
Import["https://raw.githubusercontent.com/antononcube/MathematicaForPrediction/master/QuantileRegression.m"]
AbsoluteTiming[
smoothArr = Table[MedianFilter[x, n], {n, a, b, factor*step}];
ts = N@Transpose[{Rescale@Range[Length[Mean[smoothArr]]],
Mean[smoothArr]}];
qfuncs = QuantileRegression[
Join[ts[[1 ;; 10]],
RandomSample[ts[[21 ;; -11]], UpTo[sampleSize]], ts[[-10 ;; -1]]],
nKnots, {0.5},
Method -> {LinearProgramming, Method -> "InteriorPoint",
Tolerance -> 1.}, InterpolationOrder -> 3];
smoothQR =
Table[qfuncs[[1]][y], {y, ts[[1, 1]], ts[[-1, 1]], (
ts[[-1, 1]] - ts[[1, 1]])/(Length[x] - 1)}];
]
(* {1.72669, Null} *)
grOpts = {PlotRange -> All, PlotTheme -> "Detailed",
ImageSize -> 450}; ListLinePlot[{smooth, smoothQR},
PlotLegends -> SwatchLegend[{"smooth", "smoothQR"}], grOpts]
ListPlot[Abs[smooth - smoothQR]/Abs[smooth],
PlotLegends ->
RecordsSummary[
Abs[smooth - smoothQR]/Abs[smooth], {"Relative error"}],
PlotLabel ->
Row[{"Relative error, ",
HoldForm[Abs[smooth - smoothQR]/Abs[smooth]]}], grOpts]

MeanFilter
rather thanMedianFilter
? $\endgroup$ – JimB Dec 27 '16 at 6:43