What is my code missing?

I make a selection (top) and then run my macro and though the macro does fine it leaves the selection in this state (bottom) whereby requiring me to deselect and select again

What is my code missing?

Sub BreakDimensions()
Optimization = True
ActiveDocument.BeginCommandGroup "BreakDimension"
Dim sr As ShapeRange, s As Shape
Set sr = ActiveSelectionRange
For Each s In sr
If Not s.Type = cdrLinearDimensionShape Then
s.RemoveFromSelection
End If
Next s
ActiveSelection.BreakApart
sr.AddToSelection
sr.Group
Optimization = False
ActiveDocument.EndCommandGroup
End Sub