Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

XY-Diagramm, Fläche unter Linie füllen

XY-Diagramm, Fläche unter Linie füllen
Joachim
Hallo,
ich will die Fläche unter eine xy-Diagramm füllen. Das Diagramm selbst wird über Makros formatiert.
siehe Userbild
Im Internet hab ich schon gegooglet und folgendes (leider noch nicht) passendes gefunden:
Sub ShadeBelow()
Dim myCht As Chart
Dim mySrs As Series
Dim Npts As Integer, Ipts As Integer
Dim myBuilder As FreeformBuilder
Dim myShape As Shape
Dim Xnode As Double, Ynode As Double
Dim Xmin As Double, Xmax As Double
Dim Ymin As Double, Ymax As Double
Dim Xleft As Double, Ytop As Double
Dim Xwidth As Double, Yheight As Double
Set myCht = ActiveChart
Xleft = myCht.PlotArea.InsideLeft
Xwidth = myCht.PlotArea.InsideWidth
Ytop = myCht.PlotArea.InsideTop
Yheight = myCht.PlotArea.InsideHeight
Xmin = myCht.Axes(1).MinimumScale
Xmax = myCht.Axes(1).MaximumScale
Ymin = myCht.Axes(2).MinimumScale
Ymax = myCht.Axes(2).MaximumScale
Set mySrs = myCht.SeriesCollection(1)
Npts = mySrs.Points.Count
' first point
Xnode = Xleft + (mySrs.XValues(1) - Xmin) * Xwidth / (Xmax - Xmin)
Ynode = Ytop + Yheight
Set myBuilder = myCht.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)
' remaining points
For Ipts = 1 To Npts
Xnode = Xleft + (mySrs.XValues(Ipts) - Xmin) * Xwidth / (Xmax - Xmin)
Ynode = Ytop + (Ymax - mySrs.Values(Ipts)) * Yheight / (Ymax - Ymin)
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Next
Xnode = Xleft + (mySrs.XValues(Npts) - Xmin) * Xwidth / (Xmax - Xmin)
Ynode = Ytop + Yheight
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Xnode = Xleft + (mySrs.XValues(1) - Xmin) * Xwidth / (Xmax - Xmin)
Ynode = Ytop + Yheight
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Set myShape = myBuilder.ConvertToShape
With myShape
' USE YOUR FAVORITE COLORS HERE
.Fill.ForeColor.SchemeColor = 12
.Line.Visible = False
End With
End Sub
Das Ergebnis sieht dann so aus:
Userbild
Wie kireg ich es hin, dass die shape bei 260 endet und nicht darüber hinausragt?
Und wie lösch ich die shape? Mit with .delete gehts nicht.
Gruss
Joachim
AW: XY-Diagramm, Fläche unter Linie füllen
19.03.2012 18:30:58
Daniel
Hi
mal ein Alternativ-Vorschlag:
wenn du relativ viele Punkte hast (also in etwa so viele wie Bildschrimpixel), dann könntest du als Workaround für diesen Fall die FEHLERINDIKATOREN nutzen, um die Fläche unter der Kurve zu färben (Kontextmenü - Datenreihe formatieren, Fehlerindikator Y)
Gruß Daniel
AW: XY-Diagramm, Fläche unter Linie füllen
20.03.2012 04:48:03
fcs
Hallo Joachim,
ich hab das Makro angepasst, so dass die Fläche unter Kurve am Skalen-Maxwert endet, wenn dieser kleiner ist als die größten X-Werte.
Falls im Diagramm eine Freihandform vorhanden ist, dann wird diese vor dem Erstellen der neuen Form gelöscht. Ich gehe mal davon aus, dass dies die einzige Freihandform im Diagramm ist.
Gruß
Franz
Sub ShadeBelow()
Dim myCht As Chart
Dim mySrs As Series
Dim Npts As Integer, Ipts As Integer
Dim myBuilder As FreeformBuilder
Dim myShape As Shape
Dim Xnode As Double, Ynode As Double
Dim Xmin As Double, Xmax As Double
Dim Ymin As Double, Ymax As Double
Dim Xleft As Double, Ytop As Double
Dim Xwidth As Double, Yheight As Double
Set myCht = ActiveChart
Call Shape_LoescheninChart(objSheet:=myCht)
Xleft = myCht.PlotArea.InsideLeft
Xwidth = myCht.PlotArea.InsideWidth
Ytop = myCht.PlotArea.InsideTop
Yheight = myCht.PlotArea.InsideHeight
Xmin = myCht.Axes(1).MinimumScale
Xmax = myCht.Axes(1).MaximumScale
Ymin = myCht.Axes(2).MinimumScale
Ymax = myCht.Axes(2).MaximumScale
Set mySrs = myCht.SeriesCollection(1)
Npts = mySrs.Points.Count
' first point
Xnode = Xleft + (mySrs.XValues(1) - Xmin) * Xwidth / (Xmax - Xmin)
Ynode = Ytop + Yheight
Set myBuilder = myCht.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)
' remaining points
For Ipts = 1 To Npts
If mySrs.XValues(Ipts) > Xmax Then
'Knotenpunkt interpolieren für den max. Skalenwert.
Xnode = Xleft + (Xmax - Xmin) * Xwidth / (Xmax - Xmin)
Ynode = Ytop + (Ymax - (mySrs.Values(Ipts - 1) + _
(mySrs.Values(Ipts) - mySrs.Values(Ipts - 1)) / _
(mySrs.XValues(Ipts) - mySrs.XValues(Ipts - 1)) * _
(Xmax - mySrs.XValues(Ipts - 1)))) * Yheight / (Ymax - Ymin)
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Exit For
End If
Xnode = Xleft + (mySrs.XValues(Ipts) - Xmin) * Xwidth / (Xmax - Xmin)
Ynode = Ytop + (Ymax - mySrs.Values(Ipts)) * Yheight / (Ymax - Ymin)
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Next
If Ipts > Npts Then
'alle Punkte der Kurve im Diagramm
Xnode = Xleft + (mySrs.XValues(Npts) - Xmin) * Xwidth / (Xmax - Xmin)
Ynode = Ytop + Yheight
Else
'Skalen-Max-Wert ist kleiner als der größte X-Wert
Xnode = Xleft + (Xmax - Xmin) * Xwidth / (Xmax - Xmin)
Ynode = Ytop + Yheight
End If
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Xnode = Xleft + (mySrs.XValues(1) - Xmin) * Xwidth / (Xmax - Xmin)
Ynode = Ytop + Yheight
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Set myShape = myBuilder.ConvertToShape
With myShape
' USE YOUR FAVORITE COLORS HERE
.Fill.ForeColor.SchemeColor = 12
.Line.Visible = False
End With
End Sub
Sub Shape_LoescheninChart(Optional objSheet As Object, Optional lngType As Long = 5)
'Type = 5 = Freihandform
Dim objShape As Shape
If objSheet Is Nothing Then Set objSheet = ActiveSheet
For Each objShape In objSheet.Shapes
With objShape
If .Type = lngType Then
.Delete
Exit Sub
End If
End With
Next
Ende:
Set objShape = Nothing
End Sub

Anzeige
AW: XY-Diagramm, Fläche unter Linie füllen
20.03.2012 10:39:30
Joachim
Hallo Franz,
bin erst jetzt zum Testen gekommen.
Es kommt ein Laufzeitfehler 9 bei:
Ynode = Ytop + (Ymax - (mySrs.Values(Ipts - 1) + _
(mySrs.Values(Ipts) - mySrs.Values(Ipts - 1)) / _
(mySrs.XValues(Ipts) - mySrs.XValues(Ipts - 1)) * _
(Xmax - mySrs.XValues(Ipts - 1)))) * Yheight / (Ymax - Ymin)
Gruss
Joachim
AW: XY-Diagramm, Fläche unter Linie füllen
21.03.2012 07:51:04
fcs
Hallo Joachim,
in der Datentabelle beginnen deine X-Werte scheinbar nicht mit dem kleinsten X-Wert (0) sondern mit den Werten größer als max. Skalenwert.
Da müssen dann zuzätzliche Prüfungen eingebaut werden und die Linienzugpunkte anders berechnet werden. Ich hoffe so funktioniert es mit deinen Werten.
Gruß
Franz
Sub ShadeBelow()
Dim myCht As Chart
Dim mySrs As Series
Dim Npts As Integer, Ipts As Integer
Dim myBuilder As FreeformBuilder
Dim myShape As Shape
Dim Xnode As Double, Ynode As Double
Dim Xmin As Double, Xmax As Double
Dim Ymin As Double, Ymax As Double
Dim Xleft As Double, Ytop As Double
Dim Xwidth As Double, Yheight As Double
Dim NullNachMax As Integer
Set myCht = ActiveChart
Call Shape_LoescheninChart(objSheet:=myCht)
Xleft = myCht.PlotArea.InsideLeft
Xwidth = myCht.PlotArea.InsideWidth
Ytop = myCht.PlotArea.InsideTop
Yheight = myCht.PlotArea.InsideHeight
Xmin = myCht.Axes(1).MinimumScale
Xmax = myCht.Axes(1).MaximumScale
Ymin = myCht.Axes(2).MinimumScale
Ymax = myCht.Axes(2).MaximumScale
Set mySrs = myCht.SeriesCollection(1)
Npts = mySrs.Points.Count
' remaining points
If mySrs.XValues(1) > Xmax Then
NullNachMax = 2 'die ersten X-Werte sind >Xmax
Xnode = Xleft + (Xmax - Xmin) * Xwidth / (Xmax - Xmin)
' first point
Ynode = Ytop + Yheight
Set myBuilder = myCht.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)
Else
NullNachMax = 1 'die letzten X-Werte sind >Xmax
' first point
Xnode = Xleft + (mySrs.XValues(1) - Xmin) * Xwidth / (Xmax - Xmin)
Ynode = Ytop + Yheight
Set myBuilder = myCht.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)
End If
For Ipts = 1 To Npts
If NullNachMax = 1 Then
If mySrs.XValues(Ipts) > Xmax Then
Xnode = Xleft + (Xmax - Xmin) * Xwidth / (Xmax - Xmin)
Ynode = Ytop + (Ymax - (mySrs.Values(Ipts - 1) + _
(mySrs.Values(Ipts) - mySrs.Values(Ipts - 1)) / _
(mySrs.XValues(Ipts) - mySrs.XValues(Ipts - 1)) * _
(Xmax - mySrs.XValues(Ipts - 1)))) * Yheight / (Ymax - Ymin)
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Exit For
Else
Xnode = Xleft + (mySrs.XValues(Ipts) - Xmin) * Xwidth / (Xmax - Xmin)
Ynode = Ytop + (Ymax - mySrs.Values(Ipts)) * Yheight / (Ymax - Ymin)
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
End If
ElseIf NullNachMax = 2 Then
Do Until mySrs.XValues(Ipts)  Npts Then
'alle Punkte der Kurve im Diagramm
Xnode = Xleft + (mySrs.XValues(Npts) - Xmin) * Xwidth / (Xmax - Xmin)
Ynode = Ytop + Yheight
Else
'Skalen-Max-Wert ist kleiner als der größte X-Wert
Xnode = Xleft + (Xmax - Xmin) * Xwidth / (Xmax - Xmin)
Ynode = Ytop + Yheight
End If
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Xnode = Xleft + (mySrs.XValues(1) - Xmin) * Xwidth / (Xmax - Xmin)
Ynode = Ytop + Yheight
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Set myShape = myBuilder.ConvertToShape
With myShape
' USE YOUR FAVORITE COLORS HERE
.Fill.ForeColor.SchemeColor = 12
.Line.Visible = False
End With
End Sub
Sub Shape_LoescheninChart(Optional objSheet As Object, Optional lngType As Long = 5)
'Type = 5 = Freihandform
Dim objShape As Shape
If objSheet Is Nothing Then Set objSheet = ActiveSheet
For Each objShape In objSheet.Shapes
With objShape
If .Type = lngType Then
.Delete
Exit Sub
End If
End With
Next
Ende:
Set objShape = Nothing
End Sub

Anzeige
AW: XY-Diagramm, Fläche unter Linie füllen
21.03.2012 08:53:05
Joachim
Hallo Franz,
jetzt erscheint überhaupt keine shape!
Deine Annahme ist richtig, in der Datentabelle beginnen die X-Werte nicht mit dem kleinsten X-Wert (0) sondern mit den Werten größer als max. Skalenwert.
Die x-und y-Werte sind dynamisch über Namen definiert (Bereich.verschieben...).
Die X-Werte sind immer positiv, die Y-Werte können auch ins Negative gehen.
X-Achse: Der Maxwert ist auf 260, der Minwert auf 0 eingestellt.
Y-Achse: Der Maxwert und die Schrittweite werden aus Zellen per Makro ausgelesen und übergeben, der Minwert ist auf 0 eingestellt.
Die Linie kann auch schon vor 260 ins Negative gehen, wird aber durch den festen Minwert der Y-Achse dann unterdrückt.
Ich hoffe, diese Angaben reichen dir.
Vielen Dank für dein Bemühen bis jetzt.
Gruss
Joachim
Anzeige
AW: XY-Diagramm, Fläche unter Linie füllen
22.03.2012 01:22:22
fcs
Hallo Joachim,
ich hab noch ein wenig um negative Werte (bzw. Werte kleiner Minimalwert Y-Achse) herum probiert. Damit die Flächendarstellung funktioniert werden negative/Werte kleiner Y-Min-Wert auf den Y-Min-Wert gesetzt.
Andernfalls ist die Flächendarstellung komplettes Chaos.
Und ich hab keine Lust mich hier mit allen möglichen Ausnahmen zu beschäftigen
Hier eine Beispieldatei mit Makro.
https://www.herber.de/bbs/user/79485.xls
Ich hab hier eine "einfache" Datenreihe im Diagramm verarbeitet.
Gruß
Franz
Anzeige
AW: XY-Diagramm, Fläche unter Linie füllen
22.03.2012 12:15:45
Joachim
Hallo Franz,
bei meinem Diagramm erscheint immer noch keine Fläche.
Lassen wir bleiben.
Vielen Dank für deine Mühe!!
LG
Joachim

41 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige