Option Explicit
Rem zeichne fehlende nach Vorgabe in Liste
Rem Mindestanforderung 1 Objekt vom Typ
Sub ZeichneNachListe()
Dim shShapes As Worksheet, shLists As Worksheet
Dim rngList As Range, rngCell As Range
Dim objShpe As Shape
Dim sngSTop As Single, sngLeft As Single
Set shShapes = Sheets("Checklist Structure")
Set shLists = Sheets("Lists")
Set rngList = shLists.Cells(Rows.Count, "D").End(xlUp)
Set rngList = shLists.Range("D3:G" & rngList.Row)
rngList.Interior.ColorIndex = xlColorIndexNone
For Each rngCell In rngList
For Each objShpe In shShapes.Shapes
If objShpe.TextFrame2.TextRange.Text = rngCell.Value Then _
rngCell.Interior.ColorIndex = 4
Next objShpe
Next rngCell
For Each rngCell In rngList
If rngCell.Interior.ColorIndex = xlColorIndexNone And _
rngCell.Value <> "" Then _
rngCell.Interior.ColorIndex = 3
Next rngCell
With shShapes
For Each rngCell In rngList
If rngCell.Interior.ColorIndex = 3 Then
sngSTop = .Shapes(.Shapes.Count).Top
sngSTop = sngSTop + .Shapes(.Shapes.Count).Height + 10
sngLeft = .Shapes(.Shapes.Count).Left
Set objShpe = .Shapes(.Shapes.Count).Duplicate
With objShpe
.TextFrame2.TextRange.Characters.Text = rngCell.Value
.Top = sngSTop
.Left = sngLeft
End With
End If
Next rngCell
End With
End Sub