Copying and pasting an image in Excel locks the reference

Question

Im trying to manage pictures with VBA and im having some trouble

I have an Excel spreadsheet with a picture that has a custom name "Flower"

When I copy and paste, the new image keeps the same name "Flower"

I added a macro that when I click on the picture, it tells me which picture im clicking.

Sub ImageClicked()
' ImageClicked

    shapeID = ActiveSheet.Shapes(Application.Caller).ID 
    MsgBox (shapeID)
End Sub

But the problem is that when I click on both images, the output is the same, it shows the same ID.

When I delete the first original image and click on the second image, the showed ID changes.

Is anything that im doing wrong?

P.S. Ive already figured out that if my original shape is a "Rectangle 1", then the copied shape is "Rectangle 2" and there are no problems.

Answer 1

The issue you actually run into is that your shape names are not unique and VBA now picks the first shape it finds with that name. This is due to a bug in Excel that if you copy shapes their name is exactly the same while it should not possible to have duplicate names.

I came through this bug several times, so I wrote a code to easily fix that and ensure shape names are unique. Sometimes you are not in control over the copy/paste process because other users did that and still need unique names.

You can use the following code to ensure unique shape names in the active sheet.

Option Explicit

Public Sub MakeShapeNamesUniqueInActiveSheet()
    MakeShapeNamesUnique InWorksheet:=ActiveSheet
End Sub

Public Sub MakeShapeNamesUnique(ByVal InWorksheet As Worksheet)
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    
    ' collect all shape names and how often they occur
    Dim Shp As Shape
    For Each Shp In InWorksheet.Shapes
        If Dict.Exists(Shp.Name) Then
            Dict(Shp.Name) = Dict(Shp.Name) + 1
        Else
            Dict.Add Shp.Name, 1
        End If
    Next Shp
    
    ' check which need to be renamed (duplicates) and rename them
    Dim Key As Variant
    For Each Key In Dict.keys
        If Dict(Key) > 1 Then  ' rename only if dupicate names exist
            Dim iCount As Long
            iCount = 1
            
            Dim iShp As Long
            For iShp = 1 To Dict(Key)
                Dim NewName As String
                NewName = Key & iCount
                
                ' make sure already existing new names get jumped
                Do While ShapeExists(NewName, InWorksheet)
                    iCount = iCount + 1
                    NewName = Key & iCount
                Loop
                
                InWorksheet.Shapes(Key).Name = NewName  ' rename the shape
                iCount = iCount + 1
            Next iShp
        End If
    Next Key
End Sub


Public Function ShapeExists(ByVal ShapeName As String, ByVal InWorksheet As Worksheet) As Boolean
' Test if a shape exists in a worksheet
    On Error Resume Next
    Dim Shp As Shape
    Set Shp = InWorksheet.Shapes(ShapeName)
    On Error GoTo 0
    
    ShapeExists = Not Shp Is Nothing
End Function

For example if you have the following shape names in your sheet

Flower
Flower
Flower
Flower
Flower2
Bus
Car
Car
Car

After using the code the got renamed to

Flower1
Flower3
Flower4
Flower5
Flower2
Bus
Car1
Car2
Car3

Note that the renaming algorithm detects if renaming is necessary. For example Bus didn't need to be renamed as it was unique already. Also it detects that Flower2 already existed and jumps that number 2 when renaming the 4 Flower shapes so you end up with Flower1…5 otherwise you would end up with 2 Flower2 shapes.

---

The following code snippet can be used for debugging to list all the shape names and check them quickly:

Public Sub ListAllShapeNamesInActiveSheet()
    ListAllShapeNames InWorksheet:=ActiveSheet
End Sub

Public Sub ListAllShapeNames(ByVal InWorksheet As Worksheet)
    Dim Shp As Shape
    For Each Shp In InWorksheet.Shapes
        Debug.Print Shp.Name
    Next Shp
End Sub