Kreissektor mit excel zeichnen

Question

Ein herzliches Hallo an die Runde!

Ich möchte einen Kreissektor mit excel zeichnen. Dass dies möglich ist, kenne ich von einem kürzlich angesehenen Video.

Trotz meiner Recherchen im Internet ist es mir bisher nicht gelungen, eine mögliche Umsetzung via excel zu finden. Daher wende ich mich ans Forum in der Hoffnung, dass jemand bei der Umsetzung meines Vorhabens behilflich ist oder einen entscheidenden Tipp geben kann.

LG Robert

Answer 1

Hallo Robert,

wird dir denn in dem Video nicht gezeigt, wie du sowas einfügen kannst? Das ist eigentlich ganz einfach:

Es gibt sogenannte Standardformen bzw. Autoformen, die je nach Excelversion woanders zu finden sind. Bis Excel 2003 waren sie auf der Symbolleiste "Zeichnen". In neueren Excel-Versionen kannst du sie über das Ribbon "Einfügen" finden. Hier ein Scrennshot von Excel 2019. Das Kreissegment hab ich dir rot markiert.

Anschließend markierst du die Form und ziehst an den (hier gelb markierten) Anfassern solange bis du die gewünschte Form erreicht hast.

Die Größe kannst du dann wie gewohnt über Rechtsklick auf die Form anpassen.

Leider kannst du über "Form anpassen" keine exakten Gradzahlen für die Anfasser mitgeben. Solltest du also, wie in deinem Bild oben gezeigt, exakte Werte für Winkel und Radius hinterlegen wollen, eignet sich ein kleines Makro am ehesten zur korrekten Darstellung der Form. Die Anfasser werden in Grad angegeben. Wobei 0° rechts ist, 90° unten und 180° links. Oben ist dann -90°, was sich dann bis zu -179,999999° nach links durchzieht.

Hier der Code für das Makro:

Sub Kreissegment_Zeichnen()
    
    Dim Radius As Single
    Radius = 0.98 'in cm
    
    With ActiveSheet.Shapes.AddShape(msoShapePie, Selection.Left, Selection.Top, Application.CentimetersToPoints(Radius * 2), Application.CentimetersToPoints(Radius * 2))
      .Adjustments.Item(1) = -120
      .Adjustments.Item(2) = 0
    End With
    
End Sub

Gruß Mr. K.

Answer 2

Guten Morgen, Mr. K.

Recht herzlichen Dank für deine Antwort. Ich habe meine Frage zu wenig exakt formuliert, aber ich habe ein Makro gesucht, um die Grafik (Kreissektor) dynamisch gestalten zu können. Dein "kleines Makro", wie du es nennst, erfüllt schon meine Vorstellungen.

Eine Frage hätte ich noch: Ich habe zur besseren Visualisierung meiner SchülerInnen einen Kreis um den Kreissektor gelegt. Wie muss ich das Makro abändern, dass dieses bei der Eingabe eines neuen Winkels automatisch startet und die Grafik sich dann auch automatisch anpasst (der Wert für den Radius dient nur für meine Berechnungen).
Ich wünsche allen einen guten Start ins Wochenende.

Robert

Answer 3

Hi Robert,

dafür solltest du die beiden Shapes gruppieren und der Gruppe einen sinnvollen Namen zuweisen. Ein GroupShape lässt sich leichter verschieben und in der Größe anpassen. Achte vor dem Gruppieren darauf, dass sich das Kreissegment im Vordergrund befindet.

Das Makro kommt dann in das entsprechende Tabellenmodul. Der Vollständigkeit halber habe ich das Anlegen_Makro erweitert, falls du den Kreis mal neu anlegen willst. Die automatische Änderung erfolgt über das Makro Worksheet_Change.

Sub Kreissegment_Anlegen()
  
  Dim Grad As Single, Radius As Single 'Radius in cm

  Grad = Range("C5")
  Radius = Range("C6")

  If Radius = 0 Then
    MsgBox "Geben Sie zuerst einen Radius an"
    Exit Sub
  End If
    
  With ActiveSheet.Shapes.AddShape(msoShapeOval, Selection.Left, Selection.Top, Application.CentimetersToPoints(Radius * 2), Application.CentimetersToPoints(Radius * 2))
    .Line.ForeColor.RGB = RGB(212, 162, 125) 'bräunlich
    .Fill.ForeColor.RGB = RGB(255, 255, 255) 'weiß
    '.Fill.Visible = msoFalse                 'durchsichtig
  End With
  With ActiveSheet.Shapes.AddShape(msoShapePie, Selection.Left, Selection.Top, Application.CentimetersToPoints(Radius * 2), Application.CentimetersToPoints(Radius * 2))
    .Adjustments.Item(1) = Grad * -1 'entgegen dem Uhrzeigersinn zeichnen
    .Adjustments.Item(2) = 0         'von ganz rechts ausgehend
  End With
  With ActiveSheet.Shapes.Range(Array(ActiveSheet.Shapes.Count, ActiveSheet.Shapes.Count - 1))
    .Group 'gruppiert die beiden zuvor angelegten Shapes
    .Name = "Testkreis"
  End With

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Select Case Target.Address(False, False)
    Case "C5" 'Grad
      ActiveSheet.Shapes("Testkreis").GroupItems(2).Adjustments(1) = Target * -1
    Case "C6" 'Radius
      ActiveSheet.Shapes("Testkreis").Width = Application.CentimetersToPoints(Target * 2)
      ActiveSheet.Shapes("Testkreis").Height = Application.CentimetersToPoints(Target * 2)
    End Select
End Sub

Gruß Mr. K.

Answer 4

Hallo Mr. K!

Super! Dein Makro erfüllt ganz genau meine Vorstellungen.  Nochmals einen herzlichen Dank für deine Hilfe.

Robert