Da du dir jedoch mit großer Wahrscheinlichkeit was gedacht hast

Option Explicit

Const StartData As String = "D3"

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

  Select Case Sh.Name
    Case "Lists"
      
      If Application.Intersect(Columns(Target.column), _
        Sh.Range(StartData).CurrentRegion) _
          Is Nothing Then Exit Sub

      FishMyShape Target

    'case
    '
    '
  End Select
End Sub

Private Sub FishMyShape(myCell As Range)
Const myShpType As Long = 5
Dim strgShapeID As String
  
  'ID = Type & DataCell.Address - present ?
  strgShapeID = Format(myShpType, "000") & Replace(myCell.Address, "$", "")
  On Error GoTo errorhandler
  With Sheets("Checklist Structure").Shapes(strgShapeID)
    If Len(Trim(myCell.Text)) > 0 Then
      .TextFrame2.TextRange.Characters.Text = myCell.Text
    Else
      .Delete 'or Visible Property
    End If
  End With
  Exit Sub
errorhandler:
AddShape myCell
End Sub

Sub AddShape(myCell As Range)
 
Dim shp As Excel.Shape
Dim myT, myL As Single
 
Const myShpType As Long = 5 'Shp Type rounded rectangle
Const W As Single = 160.5
Const H As Single = 19.5
Const T As Single = 276.4688
Const L As Single = 211.5
Const Gap As Single = 29.2243
 
myT = CSng(T + (Gap * (myCell.row - Range(StartData).row)))
myL = CSng(L * (1 + (myCell.column - Range(StartData).column)))
     
    Set shp = Worksheets("Checklist Structure").Shapes.AddShape(myShpType, myL, myT, W, H)
           
    With shp 'shape properties, style, macros etc.
     .TextFrame2.TextRange.Characters.Text = myCell.Value
     .Fill.ForeColor.RGB = RGB(255, 255, 255)
     .TextFrame2.VerticalAnchor = msoAnchorMiddle
     .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
     .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
     .OnAction = "'" & ThisWorkbook.Name & "'!RoundedRectangleSubcategory_Click"
     'prepare with ID for future action
     .Name = Format(myShpType, "000") & Replace(myCell.Address, "$", "")
    End With
     
End Sub