Option Explicit

Sub MoveDuplicate()
ActiveDocument.PreserveSelection = False
Dim s As Shape
Dim stest As Shape
Optimization = True
For Each s In ActiveLayer.Shapes
If s.PositionX <> 0 And s.PositionY <> 0 Then
For Each stest In ActiveLayer.Shapes
If stest.PositionX <> 0 And stest.PositionY <> 0 Then
If stest.PositionX = s.PositionX And _
stest.PositionY = s.PositionY And _
stest.Type = s.Type And _
stest.SizeHeight = s.SizeHeight And _
stest.SizeWidth = s.SizeWidth And _
stest.StaticID <> s.StaticID Then
stest.SetPosition 0, 0
Exit For
End If
End If
Next stest
End If
Next s
Optimization = False
ActiveDocument.PreserveSelection = True
ActiveDocument.ActiveWindow.Refresh
End Sub

removeUnderlyingDups - убирает точные копии кривых, лежащие друг под другом