Replacing a for-loop with something functional

Best to try and work with the entire lists rather than loop through it with For or Table.

You obviously have your reasons for your algorithm but to me it is strange because if your test returns True then you effectively increment twice. Which you can see with this version of your code:

list = {};
new = data[[All, 1]]
For[i = 1, i < Length[data[[All, 1]]] - 1, ++i,
  test = Abs[data[[i, 1]] - data[[i + 1, 1]]] > 2000;
  If[test,
   list = Join[list, {{i, test}}];
   new[[i + 1]] = Mean[{data[[i, 1]], data[[i + 2, 1]]}];
   ++i,
   list = Join[list, {{i, test}}]]
  ];
list

So you are not actually looping through every element in your list.

Going through what you are doing

Abs[data[[i, 1]] - data[[i + 1, 1]]]

can be rewritten for the list as

Abs[-Differences[data[[All, 1]]]]

From here, If I wanted to "loop" through every element, rather than skip some, I would do this:

positions = 
 Pick[Range[2, Length[data[[All, 1]]] - 1], 
  Thread[Abs[-Differences[data[[;; -2, 1]]]] > 2000], True];

new[[positions]] = 
  Mean /@ Transpose[{data[[positions - 1, 1]], 
     data[[positions + 1, 1]]}];

So what happens in this code is that you test which elements need to be replaced in one go rather than via a loop. You then apply that test to find the positions in your list that get replaced. You could also use Position and I would recommend trying that as well to see which is the more efficient ...Pick is likely to be faster for longer lists. ListCorrelate is another function that could be used to develop a solution.

To address your increment jumping I've made the following modification:

new1 = data[[All, 1]];
tmp = # > 2000 & /@ Abs[-Differences[data[[;; -2, 1]]]];
true = Rest@FoldList[If[#1 == #2, False, #2] &, False, tmp];
positions = Pick[Range[2, Length[data[[All, 1]]] - 1], true, True];
new1[[positions]] = 
  Mean /@ Transpose[{data[[positions - 1, 1]], 
     data[[positions + 1, 1]]}];
new1

Test

SeedRandom[123];
data = RandomReal[{1, 10000}, {30000, 2}];

On my computer -- V9.0.1 OS X -- your method (returning new) took 27 seconds mine (returning new1) took 0.054 seconds. A not too shabby 500 times improvement.

new==new1

(* True *)

There are some problems with your example code, you are incrementing i twice, it looks like you might subscript past the end of data, etc.

Consider this idea. It sounds like you are looking at triples in your data. So start with

Partition[data, 3, 1]

That is going to take overlapping triples of your data and you process each triple separately.

Now write a function that takes three consecutive items and returns a (potentially) cleaned first item.

f[{{x1_,__},{x2_,__},{x3_,__}}]:=If[x1-x2>2000, (x1+x3)/2, x1];

That takes a list of three rows from your data and if the difference between the first item in the first two rows is too great then averages the first and third, otherwise it gives you the unchanged first item. (This doesn't exactly match your verbal description, but your verbal description doesn't match your example code, Hopefully you can see how you want to change this to get what you really want).

Now you would like to use that function f on every triple, so

Map[f, Partition[data, 3, 1]]

Given data = {{1875.81, 1, 2}, {-1613.51, 2, 3}, {533.669, 3, 4}, {-1758.47, 4, 5}, {1613.63, 5, 6}, {100.325, 6, 7}}

it give you

{1204.74, -1613.51, 1073.65, -1758.47}

and you can try to check if that does exactly what you want

For demonstration purpose I'll use some simple test data

test = Range[20];
test[[5]] = 200;
test[[7]] = -200;

test

{1, 2, 3, 4, 200, 6, -200, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20}

Here is a way using one of the Sequence* functions introduced in version 10.1 of Mathematica:

(test[[# + 1]] = Mean@test[[{#, # + 2}]]) & /@ 
 SequencePosition[test, {a_, b_} /; Abs[a - b] > 2000, Overlaps -> False][[All, 1]];

test

{1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20}

For your special case:

new = data[[All, 1]];
(new[[# + 1]] = Mean@new[[{#, # + 2}]]) & /@ 
 SequencePosition[new, {a_, b_} /; Abs[a - b] > 2000, Overlaps -> False][[All, 1]];

Or broadly similar

new = ReplacePart[new,
 Thread[# + 1 -> Mean@new[[{#, # + 2}]] & /@ #] &
 [SequencePosition[new, {a_, b_} /; Abs[a - b] > 2000, Overlaps -> False][[All, 1]]]]