VBA - Copy/Paste Shape - Issue

[Spaztic]

Hoping there is an easy solution. I want the shape (arrow) to be copied into any cell that gets selected.

• Selected cell B2
• Click on the arrow in B1 (macro)
• Code is run to copy the arrow in B1 and place in B2 (the selected cell)

This seems to work ok UNLESS I select a cell that contains a dropdown BEFORE I select B2. Clicking Debug shows .OnAction = "" is an issue in my code

I noticed that in the selection pane, when I click from A2 (dropdown cell) to B2...it adds 'Drop Down 20'. This seems to be an issue. I can click SAVE and this 'Drop Down 20' goes away and everything works again.

Is there anything that can be added/modified in the code below so that 'Drop Down 20' (or whatever cell with a drop down was selected at some point) goes away when clicking on the 'arrow' (macro)?

Sub Arrow()
    Dim Sh As Shape
  
    With ActiveSheet
        ActiveCell.Activate
   
        .Shapes("Arrow").Copy
        .Paste 'inital position at selected cell
        Set Sh = .Shapes(.Shapes.Count) 'the newest shape
    End With
     
    With Sh
        Sh.Name = "Arrow2"
                      
        .OnAction = ""
       
    End With
End Sub

 

[Spaztic]

OR,
If anyone knows any (different) code that would work, I am all ears.

 

[rlv01]

I cannot reproduct it consistently, but somehow your drop down (which contains a type 8 shape) get's added as the last element of the shapes collection so that this statement

 Set Sh = .Shapes(.Shapes.Count)               'the newest shape

Gets assigned to the drop down instead of the new arrow. This workaround might be an alternative:

Sub Arrow()
    Dim Sh As Shape, ShSrc As Shape
    Dim I As Long

    With ActiveSheet
        Set ShSrc = .Shapes("Arrow")
        ShSrc.Copy
        .Paste                                        'inital position at selected cell

        Set Sh = .Shapes(.Shapes.Count)               'the newest shape

        If Sh.Type <> ShSrc.Type Then                 'fallback logic for when last element is not an arrow
            For I = .Shapes.Count To 1 Step -1
                Set Sh = .Shapes(I)
                If Sh.Type = ShSrc.Type Then
                    If (Sh.Name = ShSrc.Name) And (Sh.Top + Sh.Left) <> (ShSrc.Top + ShSrc.Left) Then
                        Exit For
                    End If
                End If
                Set Sh = Nothing
            Next I
        End If
    End With

    If Not Sh Is Nothing Then
        With Sh
            Sh.Name = "Arrow2"
            .OnAction = ""
        End With
    End If
End Sub

 

[rlv01]

You could also delete this line. It's redundant.

ActiveCell.Activate

ActiveCell is by definition already active.

 

[Spaztic]

You did it! It worked like a charm. Can't thank you enough.

 

[rlv01]