Sub UpdateShapes()
Dim startRow As Long, LastRow As Long
Dim namesCol As String, colorCol As String
Dim i As Long, j As Long
Dim shpName As String, cellColor As Long
Dim shp As Shape
Dim newShapes As String, deletedShapes As String
Dim isShapeInData As Boolean
startRow = 2
namesCol = "B"
colorCol = "B"
LastRow = Sheet008.Cells(Sheet008.Rows.Count, namesCol).End(xlUp).Row
For i = startRow To LastRow
shpName = Sheet008.Cells(i, namesCol).Value
cellColor = Sheet008.Cells(i, colorCol).DisplayFormat.Interior.Color
Set shp = Nothing
For Each potentialShape In Sheet009.Shapes
If potentialShape.AlternativeText = shpName Then
Set shp = potentialShape
Exit For
End If
Next potentialShape
If shp Is Nothing Then
Set shp = Sheet009.Shapes.AddShape(msoShapeRectangle, 650, 30, 40, 25)
shp.AlternativeText = shpName
shp.Name = shpName
If newShapes = "" Then
newShapes = shpName
Else
newShapes = newShapes & vbNewLine & shpName
End If
End If
shp.Fill.ForeColor.RGB = cellColor
shp.TextFrame.Characters.Text = shpName
shp.TextFrame.Characters.Font.Color = RGB(0, 0, 0)
shp.TextFrame.Characters.Font.Name = "Arial"
shp.TextFrame.Characters.Font.Size = 5
shp.TextFrame.Characters.Font.Bold = False
shp.Name = shpName
Next i
For Each shp In Sheet009.Shapes
shpName = shp.AlternativeText
isShapeInData = False
For j = startRow To LastRow
If Sheet008.Cells(j, namesCol).Value = shpName Then
isShapeInData = True
Exit For
End If
Next j
If Not isShapeInData And shpName <> "" Then
If deletedShapes = "" Then
deletedShapes = shpName
Else
deletedShapes = deletedShapes & vbNewLine & shpName
End If
shp.Delete
End If
Next shp
Dim message As String
If newShapes <> "" Then
message = "Folgende Shapes werden erstellt:" & vbNewLine & newShapes
MsgBox message, vbInformation, "Update neue Shapes"
End If
If deletedShapes <> "" Then
message = message & "Folgende Shapes werden gelöscht" & vbNewLine & deletedShapes
MsgBox message, vbInformation, "Update gelöschte Shapes"
End If
If message = "" Then
message = "Ausgewähltes Element" & vbNewLine & _
"wird im Layout angezeigt"
MsgBox message, vbInformation, "Update Auswahl"
End If
End Sub