Sub Test()
Dim ws As Worksheet
Dim lastRow As Long
Dim SrchRng As Range
Dim c 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")
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).row
Set SrchRng = ws.Range("D2:G" & lastRow)
For Each c In SrchRng.Cells
Found = False
If c <> "" Then
For Each shp In Worksheets("Checklist Structure").Shapes
If shp.Type = msoShapeRoundedRectangle Then
myText = shp.TextFrame2.TextRange.Characters.Text
If c.Value = myText Then
Found = True
Exit For
End If
End If
Next shp
If Found = False Then
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