![]() |
#5
|
|||
|
|||
![]()
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 |
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
Copied shape/text box pastes as an image in Word | spectator | Word | 0 | 06-04-2014 08:45 AM |
![]() |
bsapaka | Excel | 1 | 05-01-2014 06:53 AM |
Shape+text issue when saving to PDF | HMS | Word | 1 | 07-12-2013 04:43 PM |
![]() |
viuf | PowerPoint | 2 | 02-20-2012 02:11 PM |
![]() |
Hot Mumma | Word | 1 | 06-14-2011 05:15 PM |