Project Euler # 23 Mathematica - wolfram-mathematica

Question

I am solving Problem 23 of Project Euler using Mathematica:
Find the sum of all positive integers that cannot be written as the sum of two abundant numbers.
Recall that an abundant number # is one such that Total[Divisors[#]] - # > #. Here is my code:
list1 = Table[i, {i, 1, 28123}];
list2 = Select[list1, Total[Divisors[#]] - # > # && 2 * # < 28123 &];
list3 = {};
l = Length[list2];
For[i = 1, i <= l, i++,
For[j = i, j <= l, j++,
list3 = Append[list3, list2[[i]] + list2[[j]]]]];
Total[Complement[list1, list3]]
It is extremely slow; the nested For loops take an insane amount of time to evaluate.
Am I approaching this problem correctly? Is there a way to make it faster?
Edit: the reason behind the 28123 is that any number greater than it can be written as the sum of two abundant numbers.

Answer 1

Replace your loops that make list3 by this.
list3 = (list2[[#]] + list2[[# ;; -1]]) & /# Range[Length[list2]] // Flatten;
Timing gives 0.49 seconds on my old PC
update
To answer a complain that list3 as constructed in my answer gives wrong solution.
Well. It gives the same content as list3 build using the original code. This method is just faster. If the construction in the original method is wrong, then nothing I can do about that really, since the question was about how to make it faster, not correct any errors in the algorithm itself, which I am not familiar with. The assumption was the algorithm posted was correct but slow.
(*28123 replaced with smaller value to check, else will take forevever*)
(*for original algorithm to finish *)
n = 200;
list1 = Table[i, {i, 1, n}];
list2 = Select[list1, Total[Divisors[#]] - # > # && 2*# < n &];
list3 = {};
l = Length[list2];
For[i = 1, i <= l, i++,
For[j = i, j <= l, j++,
list3 = Append[list3, list2[[i]] + list2[[j]]]]];
mylist3 = (list2[[#]] + list2[[# ;; -1]]) & /# Range[Length[list2]] //Flatten;
compare
list3 - mylist3

Answer 2

(28123 replaced with smaller value to check, else will take forevever)
I would avoid for loops in Mathematica unless you have no other choice. I killed the Kernel with the above solution as it seemed to take a very long time to finish.
The solution below takes about 6 seconds on my Macbook. You can set the upper limit to 20161 as others have pointed out in the Euler forums.
Total[Complement[Range[20161],
Plus ## # & /#
Tuples[Select[Range[20161], ((DivisorSigma[1, #] - #) > #) &], 2]]]
Update:
Reading some other threads on optimizations, I discovered that replacing
Plus ## # & with Total[#]& shaves off another second.
This version takes 4.9 seconds
Total[Complement[Range[20161],
Total[#] & /#
Tuples[Select[Range[20161], ((DivisorSigma[1, #] - #) > #) &], 2]]]