Insert Custom Shape in a Cell with Specific Value

[phyxe]

Hi! I am trying to make a vba code that will insert a custom shape I drew on the sheet. Basically it's just a triangle with the following data
Height: 17.28834724
Width: 13.47456646
Left: 500.2627563
Top: 140.0082703

My sheet looks like this

what i am tryig to accomplish is that each cell that contains the letter "A" will have the shape so it will look somewhat like this

the way im doing this is manually copying and pasting the shape to the cells. and all i found from my recent searches are vba script that changes the color of an existing shape not insert a new shape, so I am now at my wits end on how to achieve this. Any help is much appreciated, thank you in advance for any advice you may give. ?

 

[Michael M]

Select a cell then run the macro

Sub MM1()
cl = Selection.Left
ct = Selection.Top
ActiveSheet.Shapes.AddShape(msoShapeRightTriangle, cl, ct, 13.47456646, 17.28834724). _
      Select
  Selection.ShapeRange.IncrementRotation 90
  With Selection.ShapeRange.Fill
      .Visible = msoTrue
      .ForeColor.ObjectThemeColor = msoThemeColorText1
      .Solid
  End With
End Sub

 

[phyxe]

Select a cell then run the macro

Sub MM1()
cl = Selection.Left
ct = Selection.Top
ActiveSheet.Shapes.AddShape(msoShapeRightTriangle, cl, ct, 13.47456646, 17.28834724). _
      Select
  Selection.ShapeRange.IncrementRotation 90
  With Selection.ShapeRange.Fill
      .Visible = msoTrue
      .ForeColor.ObjectThemeColor = msoThemeColorText1
      .Solid
  End With
End Sub

thanks I will this one out

 

[phyxe]

I was able to make it work by combining @Michael M suggestion and some codes I found here

so all in all here's the complete code

Sub rangeShapeInsert(myRange As Range)
    
    Dim posLeft As Long
    Dim posTop As Long
    Dim posWidth As Long
    Dim posHeight As Long
    Dim myShape As Shape
    
    posLeft = myRange.Left
    posTop = myRange.Top
    posWidth = myRange.Width
    posHeight = myRange.Height
    
    With myRange.Parent
        Set myShape = .Shapes.AddShape(msoShapeRightTriangle, posLeft, posTop, posWidth, posHeight)
        myShape.Flip msoFlipVertical
        With myShape.Fill
            .Visible = msoTrue
            .ForeColor.ObjectThemeColor = msoThemeColorText1
            .Solid
        End With
    End With
End Sub

Sub InsertShapes()
    
    Dim myCell As Range
    Dim cl As Range
    
    For Each myCell In ActiveSheet.Range("") 'insert static range of cells
        If myCell.Value2 = "A" Then
            RangeToLateShape myCell
            myCell.Font.TintAndShade = 0
        ElseIf myCell.Value2 = "B" Then
            RangeToCuttingClassShape myCell
            myCell.Font.TintAndShade = 0
        ElseIf myCell.Value2 = "C" Then
            Absent myCell
            myCell.Font.TintAndShade = 0
        End If
    Next myCell
        
End Sub

thank you again for the help

 

[Michael M]

Glad you managed to get a positive result...?