Rename all shapes in active sheet

[haseft]

Hi!

In Worksheet1 I have a lot of shapes, some has same name.
I want to rename all shapes in Worksheet1 to: Picture1, Picture2, Picture3, Picture4, ..... and so on.
Please help.

Function ShapeAtActiveCell() As String
Dim Sh As Shape

For Each Sh In ActiveSheet.Shapes
    If Sh.TopLeftCell.Address = ActiveCell.Address Then
       ShapeAtActiveCell = Sh.Name
       ActiveSheet.Shapes(ShapeAtActiveCell).Select
       Exit Function
    End If
Next
End Function

'--------------

Sub RenameShapes()
Dim p As String, n As Long
p = "Picture"
n = 1000

For i = 1 To n
   With Worksheets("Sheet1")
     .Shapes(ShapeAtActiveCell).Name = p + i
   End With
Next
End Sub

 

[Fluff]

How about

Sub RenameShapes()
Dim sh As Shape, i As Long
For Each sh In ActiveSheet.Shapes
   i = i + 1
   sh.Name = "Picture" & i
Next sh
End Sub

 

[haseft]

Thanks Fluff!
If I undrstand, in this case there is no need use Function ShapeAtActiveCell.
Or?

 

[Fluff]

Glad to help & thanks for the feedback