Option Explicit
Sub CreateShapes()
Dim ws As Worksheet
Dim shp As Excel.Shape
Dim lastRow As Integer
Dim rng As Range
On Error GoTo ErrHandler
Set ws = Worksheets("Lists")
Set shp = Worksheets("Checklist Structure").Shapes(1)
lastRow = ws.Cells(Rows.count, 1).End(xlUp).row
Set rng = ws.Range("D3:G" & lastRow)
With rng
For Each rng In .Cells
If .Text = shp.TextFrame2.TextRange.Characters.Text Then
MsgBox ("Succes!")
Else
MsgBox ("New shape has to be added!")
End If
Next
End With
ErrHandler:
Call MsgBox(Err.Description, vbCritical, "Error " & Err.number)
End Sub