Use object color as layer name

How about this? Kind of slow though. Couldn't get it to work using the optimization code. Hmm.maybe me macro buddies can help out.

Sub ShapesAsLayers()
Dim sr As ShapeRange, s As Shape, value1 As String, value2 As String
Set sr = ActiveSelectionRange
For Each s In sr
value1 = s.Fill.UniformColor.Name
ActivePage.CreateLayer(value1).Activate
s.Cut
ActiveLayer.Paste
Next s
End Sub

Still kind of slow but better

Sub ShapesAsLayers()
Dim sr As ShapeRange, s As Shape, value1 As String, value2 As String
Set sr = ActiveSelectionRange
Optimization = True
For Each s In sr
value1 = s.Fill.UniformColor.Name
ActivePage.CreateLayer(value1).Activate
s.Cut
ActiveLayer.Paste
Next s
Optimization = False
ActiveWindow.Refresh
Refresh
End Sub

Here we go. Much faster! Forget all that mess above.

Sub ShapesAsLayers()
Dim sr As ShapeRange, s As Shape, value1 As String, value2 As String

Set sr = ActiveSelectionRange
Optimization = True
For Each s In sr
value1 = s.Fill.UniformColor.Name

ActivePage.CreateLayer(value1).Activate
s.MoveToLayer ActiveDocument.ActiveLayer

Next s
Optimization = False
ActiveWindow.Refresh
Refresh
End Sub