There wasn't a lot of test data, so I made up my own. This seems to do
what you want, with a few extras - matching pairs of +ve and -ve
values are identified in column E when finished, and a colour is used
to identify those values which have been paired. Colours are allocated
in bands according to value. As you showed £ in your test data, values
are only checked down to pence.
If you want to delete the matching pairs, you can apply autofilter to
column E, selecting Non-blanks from the drop-down and then deleting
the visible records.
Be wary of spurious line breaks in the code which the newsgroup viewer
you are using might introduce.
Sub Mark_duplicates()
'
' 04/10/2007, Pete Ashurst
' amended 17/10/07
' amended 22/10/07
' amended 26/09/08
'
Dim my_top As Long
Dim my_bottom As Long
Dim colour As Integer
Dim my_pair As Integer
Application.ScreenUpdating = False
Columns("E:F").Select
Selection.Insert Shift:=xlToRight
Selection.NumberFormat = "General"
Range("E1").Select
ActiveCell.Value = "1"
Range(Selection, Selection.End(xlDown)).Select
Selection.DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, Date:=xlDay, _
Step:=1, Trend:=False
Columns("A:E").Select
Selection.Sort Key1:=Range("D1"), Order1:=xlDescending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
Range("D1").Select
my_pair = 1
my_top = 1
my_bottom = Cells(Rows.Count, "D").End(xlUp).Row
Do Until my_top >= my_bottom
If Int(Cells(my_top, 4).Value * 100) / 100 =
Int(Abs(Cells(my_bottom, 4).Value) * 100) / 100 Then
Select Case Cells(my_top, 4).Value
Case Is < 50
colour = 4 'Bright Green
Case Is < 150
colour = 6 'Yellow
Case Is < 250
colour = 8 'Turquoise
Case Is < 500
colour = 39 'Lavendar
Case Else
colour = 15 'Grey
End Select
Range("D" & my_top).Interior.ColorIndex = colour
Cells(my_top, 6).Value = my_pair
Range("D" & my_bottom).Interior.ColorIndex = colour
Cells(my_bottom, 6).Value = -my_pair
my_top = my_top + 1
my_bottom = my_bottom - 1
my_pair = my_pair + 1
ElseIf Cells(my_top, 4).Value > Abs(Cells(my_bottom, 4).Value)
Then
my_top = my_top + 1
Else
my_bottom = my_bottom - 1
End If
Loop
Columns("A:F").Select
Selection.Sort Key1:=Range("E1"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
Range("E1").Select
Application.ScreenUpdating = True
End Sub
Hope this helps.
Pete