Mehrer Rechtecke untereinander mit Makro erstellen

Forumthread: Mehrer Rechtecke untereinander mit Makro erstellen

13.11.2014 18:42:04

Kasimir

Hallo an alle Helfer!
Ich möchte eine Legende mit einem Makro erstellen lassen. Dabei sollen wie in dem Bild zu sehen, Rechtecke untereinander in der Größe 1cm x 1,5cm untereinander erstellt werden. Die Anzahl der Rechtecke und die Füllfarbe sollte variabel sein. Diese Daten, also wieviel Rechtecke und die Farben, entnehme ich einer Tabelle, in der untereinander die Texte, die in den Rechtecken erscheinen sollen und in einer Spalte daneben die Farbindexwerte aufgeführt sind.
Userbild

Leider weiß ich nicht, wie der VBA-Code dafür aussehen müsste. Ich habe zwar mal das Erstellen eines Rechtecks aufgezeichnet, werde aber nicht schlau daraus. Hat von Euch vielleicht jemand ein Makro parat, das so etwas macht? Wäre super.
Danke Euch jedenfalls schon mal
MfG,
Kasimir

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Mehrer Rechtecke untereinander mit Makro erstellen

13.11.2014 19:58:58

Tino
Super Lösung, besten Dank!

13.11.2014 20:38:42

Kasimir

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.
Userbild

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

Super Lösung, besten Dank!

13.11.2014 20:38:42

Kasimir

Hallo Tino!
Besten Dank für Deine Hilfe. Mit ein paar Änderungen passt die Lösung wie die Faust aufs Auge. Wünsche Dir noch einen schönen Abend und nochmal Danke.
MfG,
Kasimir

Beliebteste Forumthreads (12 Monate)

Mehrer Rechtecke untereinander mit Makro erstellen

Forumthread: Mehrer Rechtecke untereinander mit Makro erstellen

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread