Inserting/deleting shapes via macro

[snowboy001]

Is there a way to insert and delete shapes using macro coding? If so, does anyone have an example of this kind of code.

 

[wesimmo]

This may be of use to you in terms of looking at the syntax etc.

I basically had the 4 shapes that i wanted to use set up on the sheet.

I derived which shape i needed, which colour i wanted it to be, what text i wanted in it and then where it needed to be place on the sheet (using named ranges).

Once i had that i copied the appropriate shape, changed the properties as required and then pasted it to where i needed it to be.

The code is a bit rubbish and not annotated, apologies for that, but it did work.

Sub Map_Stakeholders()

Dim wsName, RAG, Influence, Support, wsRange, wsGroup, wsOval, wsText As String
Dim wsColourR, wsColourB, wsColourG, wsRow, wsIncrement As Integer


Application.ScreenUpdating = False


Sheets("Stakeholder Analysis").Select
Range("b8").Select

wsRow = Selection.End(xlDown).Row

Do

If ActiveCell.Value = "" Then
    
    Exit Sub

End If

wsName = ActiveCell.Value
wsRAG = ActiveCell(1, 10).Value
wsInfluence = ActiveCell(1, 7).Value
wsSupport = ActiveCell(1, 6).Value

Select Case wsRAG

    Case "R"

        wsColourR = 255
        wsColourG = 0
        wsColourB = 0

    Case "A"

        wsColourR = 255
        wsColourG = 102
        wsColourB = 0

    Case "G"
        
        wsColourR = 0
        wsColourG = 255
        wsColourB = 0
        
End Select



Select Case wsInfluence

    
    Case "Influencer"
    
        wsGroup = "Inf_Group"
        wsOval = "Inf_Oval"
        wsText = "Inf_text"
        
    Case "Follower"
        
        wsGroup = "Foll_Group"
        wsOval = "Foll_Rec"
        wsText = "Foll_Text"
    
    Case "Decision Maker"
    
        wsGroup = "DM_Group"
        wsOval = "DM_Diam"
        wsText = "DM_Text"
        
    Case "Gatekeeper"
    
        wsGroup = "GK_Group"
        wsOval = "GK_Tri"
        wsText = "GK_Text"

End Select


Select Case wsSupport

    
    Case "Promoter"
    
        wsRange = "Promo"
        
    Case "Opponent"
        
        wsRange = "Oppo"
        
    Case "Supporter"
        
        wsRange = "Suppo"
        
    Case "Neutral"

        wsRange = "Neut"

End Select



Sheets("Stakeholder Map").Select

wsIncrement = Range("A6").Value
Range("A6").Value = wsIncrement + 1

ActiveSheet.Shapes(wsGroup).Ungroup

ActiveSheet.Shapes(wsText).Select
Selection.Text = wsName

ActiveSheet.Shapes(wsOval).Select
With Selection.ShapeRange(wsColourR, wsColourG, wsColourB)
End With

ActiveSheet.Shapes.Range(Array(wsOval, _
    wsText)).Group.Select

x = Selection.Name

ActiveSheet.Shapes(x).Name = wsGroup

Selection.Copy

Range(wsRange).Select

ActiveSheet.Paste

Selection.Name = wsGroup & wsIncrement


Sheets("Stakeholder Analysis").Activate

ActiveCell(2, 1).Select

Loop Until ActiveCell.Row = wsRow + 1

Sheets("Stakeholder Map").Select

y = MsgBox("ALL STAKEHOLDERS HAVE BEEN MOVED ONTO THE MAP" & vbNewLine & "PLEASE REPOSITION THEM IF REQUIRED", vbOKOnly)


End Sub