Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
Screenshot zu MsgBox	MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Informationen und Beispiele zum Thema Frame
Screenshot zu Frame	Frame-Seite mit Beispielarbeitsmappe aufrufen

Mehrer Rechtecke untereinander mit Makro erstellen

• Mehrer Rechtecke untereinander mit Makro erstellen von Kasimir vom 13.11.2014 18:42:04
• AW: Mehrer Rechtecke untereinander mit Makro erstellen - von Tino am 13.11.2014 19:58:58
  • Super Lösung, besten Dank! - von Kasimir am 13.11.2014 20:38:42

Betrifft: Mehrer Rechtecke untereinander mit Makro erstellen von: Kasimir
Geschrieben am: 13.11.2014 18:42:04

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.



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

Betrifft: AW: Mehrer Rechtecke untereinander mit Makro erstellen von: Tino
Geschrieben am: 13.11.2014 19:58:58

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

Betrifft: Super Lösung, besten Dank! von: Kasimir
Geschrieben am: 13.11.2014 20:38:42

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

Beiträge aus den Excel-Beispielen zum Thema "Mehrer Rechtecke untereinander mit Makro erstellen"