AW: Mehrer Rechtecke untereinander mit Makro erstellen
13.11.2014 19:58:58
Tino
Hallo,
kannst mal so versuchen.
Tabelle wo die Rechtecke hinsollen musst Du anpassen!
Tabelle und Range Bereich wo die Daten stehen musst Du anpassen!
Ergebnis sollte in etwa dann so aussehen.
Sub Erstelle_Legende()
Dim rngData As Range, objShape As Shape
Dim sngPosH!, sngPosV!
Const Breite! = 1.5 'Breite
Const Hoehe! = 1 'Höhe
'Points in Zentimeter Umrechnungsfaktor
Const Faktor! = 28.3464566929
'Position Horizontal
sngPosH = 5
'erste Position Vertikal
sngPosV = 5
On Error GoTo ErrorHandler:
'Wertetabelle
With Tabelle2
Set rngData = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
End With
Application.ScreenUpdating = False
'lösche alte
With Tabelle1
For Each objShape In .Shapes
If objShape.Type = msoShapeRectangle Then
If InStr(objShape.Name, "Legende_") > 0 Then
objShape.Delete
End If
End If
Next objShape
For Each rngData In rngData
Set objShape = .Shapes.AddShape(msoShapeRectangle, sngPosH, sngPosV, Breite * Faktor, Hoehe * Faktor)
With objShape
.Name = "Legende_" & rngData.Row
With .TextFrame2
.HorizontalAnchor = msoAnchorCenter
.VerticalAnchor = msoAnchorMiddle
.TextRange.Text = rngData.Text
.TextRange.Font.Fill.ForeColor.RGB = rngData.Font.Color
End With
With .Line
.ForeColor.RGB = RGB(196, 196, 196)
.Weight = 2
End With
.Fill.ForeColor.RGB = rngData.Interior.Color
sngPosV = .Top + .Height
End With
Next rngData
End With
ErrorHandler:
Application.ScreenUpdating = True
If Err.Number <> 0 Then
MsgBox Err.Description, _
vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
"Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End If
End Sub
Gruß Tino