Hello,

zunächst vielen, vielen Dank für den umfangreichen Code. Leider verstehe ich nicht, wofür ich die Subs "FishMyShape" und "CareMyShape" benötige. Also ich verstehe den Code, aber den Gesamtzusammenhang leider nicht. Beim Testen habe ich zunächst nicht deinen gesamten Code übernommen, sondern lediglich die Abschnitte, die ich nicht alleine hinbekommen habe (natürlich mit den entsprechenden Deklarationen etc.). Die Positionierung wird auch richtig ausgeführt, richtig toll :) Da du dir jedoch mit großer Wahrscheinlichkeit was gedacht hast, beim erstellen der Subs, wollte ich lieber nachfragen. Bei mir sieht das Ganze nun so aus:

Private c As Range
Const StartData As String = "D3"

Option Explicit

Private Sub CompListWthShpText()
Dim ws As Worksheet, wsCS As Worksheet
Dim SrchRng As Range
Dim Found As Boolean
Dim shp As Excel.Shape
Dim myText As Variant
Dim count As Long
Dim AllCells() As Variant
Dim i As Long

On Error GoTo ErrHandler

Set ws = Worksheets("Lists")
Set wsCS = Worksheets("Checklist Structure")
Set SrchRng = ws.Range("D3").CurrentRegion

' Check whether the subcategory already has a corresponding shape in the checklist structure
For Each c In SrchRng.Cells
Found = False
    If c <> "" Then
       For Each shp In Worksheets("Checklist Structure").Shapes
           If shp.AutoShapeType = msoShapeRoundedRectangle Then
              myText = shp.TextFrame2.TextRange.Characters.Text
              If c.Value = myText Then
              Found = True
              c.Interior.ColorIndex = 4
              Exit For
              End If
           End If
       Next shp
       
      ' if the subcategory isn't found then add shape with following coordinates and properties
      If Found = False Then
      Call AddShape
                   
        count = count + 1
        ReDim Preserve AllCells(1 To count)
        AllCells(count) = c.Value
        
      End If
    End If
Next c

For i = LBound(AllCells) To UBound(AllCells)
    MsgBox "Shape with text " & AllCells(i) & " is missing."
Next i

Exit Sub
ErrHandler:
Call MsgBox(Err.Description, vbCritical, "Fehler " & Err.number)

End Sub
Private Sub AddShape()

Dim Found As Boolean
Dim SrchRng 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

Set SrchRng = Worksheets("Lists").Range(StartData).CurrentRegion

myT = CSng(T + (Gap * (c.row - Range(StartData).row)))
myL = L * (1 + (c.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 = c.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"
    End With
    
End Sub