Hallo Experten,

Aus einer Tabelle mit zwei Spalten füge ich per VBA shapes in ein Tabellenblatt ein. Funktioniert soweit auch recht gut.

Problem ist aber, je nach Attribut der ersten Spalte sollte sich auch die Form (Rechteck, Dreieck, Kreis...) ändern.

Wie bekomme ich das in meinen Code integriert?

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