Option Explicit
Const myShpType As Long = 5           'Shp Type rounded rectangle
Const myShpWidt As Single = 160.5
Const myShpHgth As Single = 19.5

Const fstShpTop As Single = 276.4688
Const fstShpLft As Single = 211.5
Const fstShpGap As Single = 29.2243

Const StartData As String = "D3"

Dim wshData As Worksheet
Dim wshSpap As Worksheet
Dim IsExist As Boolean                'shape is in stock

Sub HoldMyShapes()
'it´s better to prepare shapes with ID´s for the future
Dim rngData As Range, c As Range

  Set wshData = ActiveWorkbook.Sheets("Lists")
  Set wshSpap = ActiveWorkbook.Sheets("Checklist Structure")
  
  Set rngData = wshData.Range(StartData).CurrentRegion
  
  For Each c In rngData
    If c.Font.Bold Then
      ElseIf c.Font.Italic Then
    Else
      IsExist = False
      If Len(Trim(c.Value)) > 0 Then
        FishMyShape c
        If Not IsExist Then MakeShape c
      End If
    End If
  Next c

End Sub

Private Sub MakeShape(myCell As Range)
Dim myTop As Single
Dim myLft As Single
Dim oShp As Object

  myTop = CSng(fstShpTop + fstShpGap * (myCell.row - Range(StartData).row))
  myLft = fstShpLft * (1 + (myCell.column - Range(StartData).column))
  
  Set oShp = wshSpap.Shapes.AddShape(myShpType, myLft, myTop, myShpWidt, myShpHgth)
  
  With oShp 'shape properties, style, macros etc.
     .TextFrame2.TextRange.Characters.Text = myCell.Text
     .Fill.ForeColor.RGB = RGB(255, 255, 255)
     .TextFrame2.VerticalAnchor = msoAnchorMiddle
     .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(112, 48, 160)
     .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
     .OnAction = "'" & ThisWorkbook.Name & "'!RoundedRectangleSubcategory_Click"
     'prepare with ID for the future (ID = Type & DataCell.Address)
     .Name = Format(myShpType, "000") & Replace(myCell.Address, "$", "")
  End With
End Sub

Private Sub FishMyShape(myCell As Range)
Dim Test
Dim strgShapeID As String
  
  'ID = Type & DataCell.Address - present ?
  strgShapeID = Format(myShpType, "000") & Replace(myCell.Address, "$", "")
  On Error GoTo errorhandler
  Test = wshSpap.Shapes(strgShapeID).Top
  IsExist = True
Exit Sub
errorhandler:
CareMyShape myCell.Text, strgShapeID
End Sub

Private Sub CareMyShape(myText As String, myID As String)
'prepare shapes with ID for the future (ID = Type & DataCell.Address)
Dim oShp As Shape
  For Each oShp In wshSpap.Shapes
    If oShp.AutoShapeType = myShpType Then
      If oShp.TextFrame2.TextRange.Characters.Text = myText Then
        oShp.Name = myID
        IsExist = True
        Exit Sub
      End If
    End If
  Next oShp
End Sub