speeding up object property changes

I'm currently using a loop that looks at each individual object in a document, checks its width and color and then either deletes it or moves it to a new layer. Some documents contain 20,000 objects. Using this type of loop is very slow. Does anyone have an ideas on how i could speed it up. The code i'm using is shown below. Many Thanks

For Each t In ActivePage.Shapes
ProgressBar1.Value = counter
counter = counter + 1
t.Outline.Color.ConvertToCMYK
If t.Outline.Width < 0.003 Then
t.Delete
ElseIf t.Outline.Color.CMYKBlack <> 100 Then
t.Outline.Width = 0.003
t.Layer = lyr
ElseIf t.Outline.Color.CMYKBlack = 100 Then
t.Outline.Width = 0.003
End If
Next