Option Explicit
Sub CreateShapes()
Dim ws As Worksheet
Dim SrchRng
Dim shp As Excel.Shape
Dim c As Range
Dim cellEntry As String
Dim lastRow
On Error GoTo ErrHandler
Set ws = Worksheets("Lists")
lastRow = ws.Cells(Rows.count, 1).End(xlUp).row
With Worksheets("Checklist Structure")
For Each shp In .Shapes
If shp.Type = msoAutoShape Then
If shp.AutoShapeType = msoShapeRoundedRectangle Then
cellEntry = ws.Range("D3:P" & lastRow).Cells.Value
SrchRng = shp.TextFrame2.TextRange.Characters.Text
Set c = SrchRng.Find(cellEntry, LookIn:=xlValues)
If Not c Is Nothing Then
MsgBox ("Succes!")
End If
End If
End If
Next shp
End With
ErrHandler:
Call MsgBox(Err.Description, vbCritical, "Error " & Err.number)
End Sub