Microsoft Excel

Herbers Excel/VBA-Archiv

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

Mehrer Rechtecke untereinander mit Makro erstellen

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"