Perfect numbers

A faster approach to finding Perfect numbers using DivisorSigma

 Select[Range[10^6], DivisorSigma[1, #] == 2 # &]

{6, 28, 496, 8128}

Here's an even faster approach:

Pick[#, MapThread[Equal, {DivisorSigma[1, #], 2 #}], True] &[Range[10^6]]

and a little bit faster:

Pick[#, DivisorSigma[1, #] - 2 #, 0] &@Range[10^6]

For Abundant numbers do:

Select[Range[10^6], (DivisorSigma[1, #] - #) > # &]

and a faster approach as above:

Pick[#, MapThread[Greater, {DivisorSigma[1, #] - #, #}], True] &[Range[10^6]]

By giving Greater the Listable Attribute we can squeeze out some more performance:

SetAttributes[Greater, Listable]
Pick[#, DivisorSigma[1, #] > 2 #, True] &@Range[10^6]

Edit :

For this particular problem since we know that the largest Perfect number is less than 10000, we can begin to hit miliseconds regime using ParallelMap:

ParallelMap[Pick[#, DivisorSigma[1, #] - 2 #, 0] &, {Range[2, 5*^3, 2], 
    Range[5*^3 + 2, 1*^4, 2]}] // Flatten // AbsoluteTiming

{0.015627, {6, 28, 496, 8128}}

Of course this will also give us speed up if we scan the entire range.

Perfect numbers:

Select[ Range[10^6], Total[Divisors @ #] == 2 # &]

{6, 28, 496, 8128}

abundant numbers:

Select[ Range[10^3], Total[ Most @ Divisors @ #] > # &]//Short

{ 12, 18, 20, 24, 30, 36, 40, 42, 48, <<228>>, 
     968, 972, 978, 980, 984, 990, 992, 996, 1000} 

I used Short to to get only a few since there are:

Count[ Range[10^3], _?(Total[Most@Divisors@#] > # &)]

246

of them.

Edit

As RunnyKine pointed out that using DivisorSigma[1, #] & is more efficient than Total @ Divisors @ # &. Another improvement might be exploiting the fact that there are no known odd perfect numbers, it was verified that there is none below 10^1500. The largest known perfect number (48-th) has only 34850340 digits i.e. IntegerLength[2^(57885161 - 1) (2^57885161 - 1)]. Taking the above into account we get 2 times speed up with:

Pick[ #, DivisorSigma[1, #] - 2 #, 0]& @ Range[2, 10^6, 2]

However we can observe there are odd abundant numbers, but they are sparsely distributed among even ones. Below 1000 there is only one ( while there are 245 even ones):

Pick[ #, UnitStep[ DivisorSigma[1, #] - 2 # - 1], 1]& @ Range[1, 10^3, 2]

{945}

Below 10^6 there are

Length @ Pick[ #, UnitStep[ DivisorSigma[1, #] - 2 # - 1], 1] & /@ 
{Range[ 2, 10^6, 2], Range[ 1, 10^6, 2]}

{245549, 1996}

even and odd abundant numbers respectively.

It is remarkable that Length @ Pick[ Range[10^6], UnitStep[ DivisorSigma[1, #] - 2 # - 1], 1]] is faster than : Count[ Range[10^6], _?(DivisorSigma[1, #] > 2 # &)].

Or how about the connection between even perfect numbers and Mersenne primes?

With[{p = Prime[Range[20]]},
     Pick[p, PrimeQ[2^p - 1]] /. q_ -> 2^(q - 1) (2^q - 1)]

Update for perfect numbers only.

As noted in previous answers, DivisorSigma[1,n] is faster than summing Divisors, and Pick is faster than Select. So even perfect numbers may be found by using

RepeatedTiming[Pick[#, DivisorSigma[1, #] - 2 #, 0] &@Range[2, 10^6, 2]]

which gives a timing of 1.34 s on my machine. These approaches are slow compared to the clever divisor sum by @MichaelE2. The repeated timing of his function is a tiny 0.056 s.

@QuantumDot points out the new v10.4 functions PerfectNumber[n] and PerfectNumberQ[n]. However, the following takes a glacial 4 seconds! Why?

RepeatedTiming[Pick[#, Map[PerfectNumberQ, #]] &@Range[2, 10^6, 2]]

The Help page for the new v10.4 function MersennePrimeExponent shows how to instantly calculate even perfect numbers.

RepeatedTiming[2^(# - 1)*(2^# - 1) &[MersennePrimeExponent[Range[4]]]]