Better code to find Narcissistic number

Here is a functional approach:

Narciss[x_] :=  With[{num = IntegerDigits[x]}, Total[num^Length[num]] == x]

Here is a compiled version of the above function:

NarcissC =  Compile[{{x, _Integer}}, 
  With[{num = IntegerDigits[x]}, Total[num^Length[num]] == x], 
  Parallelization -> True, CompilationTarget -> "C", 
  RuntimeAttributes -> Listable, RuntimeOptions -> "Speed"]

Now you can do something like

AbsoluteTiming[Position[NarcissC[Range[10000000]], True] // Flatten]

{1.003214, {1, 2, 3, 4, 5, 6, 7, 8, 9, 153, 370, 371, 407, 1634, 8208, 9474, 54748, 92727, 93084, 548834, 1741725, 4210818, 9800817, 9926315}}

to get all the m-Narcissistic numbers from 1 to 10000000.

For a further bump in speed as suggested by chyaong, here is NarcissC2 (Using Sum instead of Total)

NarcissC2 = Compile[{{x, _Integer}}, 
   With[{num = IntegerDigits[x]}, Sum[i^Length@num, {i, num}] - x], 
   CompilationTarget -> "C", RuntimeAttributes -> Listable, RuntimeOptions-> "Speed"];

Now you can do:

Pick[#, NarcissC2[#], 0] &@Range[10000000] // AbsoluteTiming

Which gives:

{0.475276, {1, 2, 3, 4, 5, 6, 7, 8, 9, 153, 370, 371, 407, 1634, 8208, 9474, 54748, 92727, 93084, 548834, 1741725, 4210818, 9800817, 9926315}}

EDIT

It turns out that you can get a bump using Total and Pick instead of Position (not as fast as Sum):

  NarcissC1 =  Compile[{{x, _Integer}}, 
    With[{num = IntegerDigits[x]}, Total[num^Length[num]] - x], Parallelization -> True, 
    CompilationTarget -> "C", RuntimeAttributes -> Listable, RuntimeOptions -> "Speed"]

Then

Pick[#, NarcissC1[#], 0] &@Range[10000000] // AbsoluteTiming

gives:

{0.626322, {1, 2, 3, 4, 5, 6, 7, 8, 9, 153, 370, 371, 407, 1634, 8208,
   9474, 54748, 92727, 93084, 548834, 1741725, 4210818, 9800817, 9926315}}

Not an answer per se, but two clarifications (which are too long for the comment box):

1) The Wiki definition you have linked to for a narcissistic number is not really apt. The Wiki page is actually describing the definition for an Armstrong Number, also known as pluperfect digital invariants, or m-narcissistic numbers, such as:

$$407 = 4^3 + 0^3 + 7^3$$

These require the use of the power term $m$ (the 3 in this example) over and above the digits of integer $n= 407$. By contrast, the correct and proper reference to the term 'narcissistic number' comes from the article by Madachy, J. S. (1966), Mathematics on Vacation, Thomas Nelson & Sons — p.163 to 175, who defines them as numbers:

"that are representable, in some way, by mathematically manipulating the digits of the numbers themselves".

What the Wiki page describes ... the Armstrong numbers ... is quite different, ... not the 'narcissistic numbers', as the page claims, but the m-narcissistic numbers. But that's wiki for you.

2) Finite to infinite: The set of narcissistic numbers involve a finite search (such as the solutions above). The problem becomes rather more tricky if you allow for the use of radicals or factorials ... because the search problem is no longer finite ... rather you can have infinite nesting of square root symbols or factorial symbols.

One can get some pretty results when you allow radicals, such as say:

For more detail, please see:

http://www.tri.org.au/numQ/pwn/

or a fun little piece I did entitled:

Radical Narcissistic Numbers, Journal of Recreational Mathematics, 33(4), 2004-2005, 250-254.

I've been meaning to put up the mma code for this too ... this was done long before the age of multi-processors, so I think I'll have to update the code for parallel cores, which would make an enormous difference here.

nar[m_] := 
  ToExpression[
   "Compile[{$},Do[With[{n=0" <> 
    StringJoin[
     Table["+1" <> Array["0" &, m - 1 - i, 1, StringJoin] <> "a" <> 
       ToString[m - 1 - i], {i, 0, m - 1}]] <> ",n2=0" <> 
    Table["+a" <> ToString[m - 1 - i] <> "^" <> ToString[m], {i, 0, 
      m - 1}] <> "},If[n\[Equal]n2,Sow@n];];,{a0" <> 
    StringJoin[Table[",0,9},{a" <> ToString[i], {i, 1, m - 1}]] <> 
    ",9}],RuntimeOptions\[Rule]\"Speed\",CompilationTarget\[Rule]\"C\"\
]"];

Reap[nar[7][0]][[2, 1]] // AbsoluteTiming

(*{1.184733, {9926315, 1741725, 9800817, 4210818}}*)

My computer is rather slow. @RunnyKine's code takes 0.901549 seconds on my computer.