Microsoft Office Forums - View Single Post

excelledsoftware · 07-08-2014, 06:17 PM

I took a look at this myself. The issue is just like Bob said. The application.caller is pulling the first shape it can. Your code works flawlessly when the shapes have different names. I started thinking why it would be necessary to have the shapes all have the same name and then it occurred to me. (I am assuming here) It is very easy to duplicate a shape in Excel by clicking and dragging with control or just copying and pasting. It is really annoying to have to go and rename all the shapes. So based off of this assumption I believe it would be helpful for you to have a way to name all of the shapes with a unique but similar name all at once. I wrote 2 procedures for you that will do this. The first renames every shape followed by a number. So if you decided to name the shapes "Default" the first shape would be Default1 then Default2 etc.

The 2nd procedure will name only the selected shapes. This one is a little more detailed since it needs to check if the name has already been taken otherwise there is no point.

Here are the 2 procedures let me know if this helps.

Code:

Sub NameAllTheShapes()
  'Names all of the shapes a set name with a unique number
  Dim shp As Shape
  Dim NewName As String
  Dim x As Integer
  
    NewName = InputBox("What is the new name for the shapes")
    If NewName = "" Then Exit Sub
    
    x = 1
  
    For Each shp In ActiveSheet.Shapes
      shp.Name = NewName & x
      x = x + 1
    Next shp
  
End Sub

Sub NameSelectedShapes()
  'Names all selected shapes
  Dim shp As Shape
  Dim SR As Variant
  Dim CheckShape(0 To 300) As String
  Dim NewName As String
  Dim x As Integer, y As Integer, TotShapes As Integer
    On Error Resume Next
    Set SR = Selection.ShapeRange
    If SR Is Nothing Then
      MsgBox "No shapes selected"
      End
    End If
    On Error GoTo 0 'Enable Errors again
    
  
    NewName = InputBox("What is the new name for the shapes")
    If NewName = "" Then Exit Sub
    y = 0
    x = 1
    
    
    For Each shp In ActiveSheet.Shapes
      CheckShape(y) = shp.Name
      y = y + 1
    Next shp
    TotShapes = y - 2
    
    
    
    'Check if the name is in use
      For Each shp In Selection.ShapeRange
        For y = 0 To TotShapes
          If CheckShape(y) = NewName & x Then
            MsgBox ("The group name " & NewName & " is already in use." _
            & vbLf & "Program ending")
            End
          End If
        Next y
        x = x + 1
      Next shp
      x = 1
            
      For Each shp In Selection.ShapeRange
        shp.Name = NewName & x
        x = x + 1
      Next shp

    
End Sub