Sub UpdateShapesArPl()
Dim startRow As Long, LastRow As Long
Dim namesCol As String, colorCol As String
Dim i As Long, j As Long
Dim shpAltName 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
shpAltName = 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 = shpAltName Then
Set shp = potentialShape
Exit For
End If
Next potentialShape
If shp Is Nothing Then
Select Case Sheet008.Cells(i, namesCol).Offset(0, -1).Value
Case "ArPl_kurz"
Set shp = Sheet009.Shapes.AddShape(msoShapeRectangle, 650, 30, 40, 25)
shp.AlternativeText = shpAltName
shp.Fill.ForeColor.RGB = cellColor
shp.TextFrame.Characters.Text = shpAltName
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 = shpAltName
Case "Halle_kurz"
Set shp = Sheet009.Shapes.AddShape(msoShapeDownArrowCallout, 700, 30, 40, 30)
shp.AlternativeText = shpAltName
shp.Fill.ForeColor.RGB = cellColor
shp.TextFrame.Characters.Text = shpAltName
shp.TextFrame.Characters.Font.Color = RGB(0, 0, 0)
shp.TextFrame.Characters.Font.Name = "Arial"
shp.TextFrame.Characters.Font.Size = 11
shp.TextFrame.Characters.Font.Bold = True
shp.Name = shpAltName
Case "IT_kurz"
Set shp = Sheet009.Shapes.AddShape(msoShapeFlowchartDecision, 750, 30, 25, 25)
shp.AlternativeText = shpAltName
shp.Fill.ForeColor.RGB = cellColor
shp.TextFrame.Characters.Text = shpAltName
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 = shpAltName
Case "LOTO_kurz"
Set shp = Sheet009.Shapes.AddShape(msoShapeDonut, 800, 30, 10, 10)
shp.AlternativeText = shpAltName
shp.Fill.ForeColor.RGB = cellColor
shp.TextFrame.Characters.Text = shpAltName
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 = shpAltName
End Select
If newShapes = "" Then
newShapes = shpAltName
Else
newShapes = newShapes & vbNewLine & shpAltName
End If
End If
Next i
For Each shp In Sheet009.Shapes
shpAltName = shp.AlternativeText
isShapeInData = False
For j = startRow To LastRow
If Sheet008.Cells(j, namesCol).Value = shpAltName Then
isShapeInData = True
Exit For
End If
Next j
If Not isShapeInData And shpAltName <> "" Then
If deletedShapes = "" Then
deletedShapes = shpAltName
Else
deletedShapes = deletedShapes & vbNewLine & shpAltName
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