Office: (Office 2013) Polynom zeichnen

Beverly · 8. Januar 2020

Hier die 3 Makros:

Code:

Sub FunktionZeichnen()
Dim lngZeile As LongPtr
Dim dblTeilung As Double
Dim strFormel
Dim strFormel2 As String
Dim intLaenge As Integer
Dim varLuecke As Variant
Application.ScreenUpdating = False
On Error GoTo Fehler
intLaenge = Len(Range("B11")) - 1
lngZeile = 1
dblTeilung = (Range("B5") - Range("B4")) / Range("B11")
strFormel = Split(Range("B1"), "x")
strFormel2 = Application.Substitute(Join(strFormel, "M" & lngZeile), ",", ".")
Columns("M:N").ClearContents
Range("M1") = Range("B4")
Range("N1") = Evaluate(strFormel2)
If IsError(Range("N1")) Then Range("N1").ClearContents
Do
lngZeile = lngZeile + 1
Cells(lngZeile, 13) = Cells(lngZeile - 1, 13) + dblTeilung
strFormel2 = "=" & Application.Substitute(Join(strFormel, "M" & lngZeile), ",", ".")
Cells(lngZeile, 14) = Evaluate(strFormel2)
varLuecke = Application.Match(Application.Round(Cells(lngZeile, 13), intLaenge), Range("B13:B17"), 0)
If IsNumeric(varLuecke) Then
Cells(lngZeile, 13) = Application.Round(Cells(lngZeile, 13), Len(Range("B11")) - 1)
Cells(lngZeile, 14).ClearContents
End If
If Cells(lngZeile, 13) >= Range("B5") Then Exit Do
Loop
With ActiveSheet.ChartObjects(1).Chart
.SetSourceData Source:=Range("M1:N" & lngZeile)
.Axes(xlValue).MinimumScale = Range("B8")
.Axes(xlValue).MaximumScale = Range("B9")
.Axes(xlCategory).MinimumScale = Range("B4")
.Axes(xlCategory).MaximumScale = Range("B5")
End With
Fehler:
Application.ScreenUpdating = True
If Err.Number 0 Then MsgBox "Es ist ein Fehler aufgetreten " & Err.Number
End Sub

Sub PunkteZeichnen()
Dim lngLetzte As Long
Dim lngZaehler As Long
lngLetzte = Columns(1).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
With ActiveSheet.ChartObjects(1).Chart
.SetSourceData Source:=Range("B10:C16")
If Range("B2") "" Then .Axes(xlCategory).MinimumScale = Range("B2")
If Range("B3") "" Then .Axes(xlCategory).MaximumScale = Range("B3")
If Range("B6") "" Then .Axes(xlValue).MinimumScale = Range("B6")
If Range("B7") "" Then .Axes(xlValue).MaximumScale = Range("B7")
With .SeriesCollection(1)
For lngZaehler = 1 To .Points.Count
.Points(lngZaehler).DataLabel.Text = _
"='Punkte Zeichnen'!" & Cells(9 + lngZaehler, 1).Address(False, False)
Next lngZaehler
End With
End With
End Sub

Sub LeeresDia()
With ActiveSheet.Shapes.AddChart2(240, xlXYScatter)
.Chart.HasTitle = False
If Range("B2") "" Then .Axes(xlCategory).MinimumScale = Range("B2")
If Range("B3") "" Then .Axes(xlCategory).MaximumScale = Range("B3")
If Range("B6") "" Then .Axes(xlValue).MinimumScale = Range("B6")
If Range("B7") "" Then .Axes(xlValue).MaximumScale = Range("B7")
.Height = 400
.Width = 400
.Top = 0
.Left = Range("D1").Left
With .Chart.SeriesCollection.NewSeries
.XValues = "={0}"
.Values = "={0}"
End With
End With
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Jeweiliges Tabellenblatt muss aktiv sein.

Sterndeuter · 9. Januar 2020

Vielen Dank, Karin, die ersten beiden Makros funktionieren! Das dritte gibt bei mir leider eine Fehlermeldung zurück (Laufzeitfehler '438': Objekt unterstützt diese Eigenschaft oder Methode nicht.). Ich hänge meine Datei mit deinen Codes nochmal an.

Noch zwei Fragen "kosmetischer" Natur:
- Ist es möglich, das Hauptgitternetz immer bei den ganzen Zahlen anzuzeigen? Im Moment wird, wie auf Blatt "Funktion zeichnen" zu sehen ist, das Hauptgitternetz auf die 0,5er-Stellen verschoben und damit auch die Formatierung der Achsen (Pfeile am Ende) nicht mehr angezeigt. Kann man das ins Makro einbauen, z.B. indem man auf Blatt 1 in Zelle B19 die Position des Hauptgitternetzes angibt ("1" für "alle ganzen Zahlen"; "2" für "jede zweite ganze Zahl" etc.)? Auf Blatt 2 und 3 dann entsprechend in Zelle B9.
- Ist es möglich, das Koordinatensystem so einzustellen, dass nicht die letzte anzuzeigende Zahl direkt am Pfeil endet (siehe "Punkte zeichnen")? Ich finde das unübersichtlich und etwas verwirrend (weil ich es eben anders gewöhnt bin, wenn ich per Hand ein Koordinatensystem zeichne).

Beverly · 9. Januar 2020

Für das Erstellen des leeren Diagramms:

Code:

Sub LeeresDia()
With ActiveSheet.Shapes.AddChart2(240, xlXYScatter, Range("D1").Left, 0, 500, 400).Chart
.HasTitle = False
If Range("B2") "" Then .Axes(xlCategory).MinimumScale = Range("B2")
If Range("B3") "" Then .Axes(xlCategory).MaximumScale = Range("B3")
If Range("B6") "" Then .Axes(xlValue).MinimumScale = Range("B6")
If Range("B7") "" Then .Axes(xlValue).MaximumScale = Range("B7")
With .SeriesCollection.NewSeries
.XValues = "={0}"
.Values = "={0}"
End With
End With
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Das Hauptgitternetz kannst du doch ganz nach deinen Wünschen einstellen. Dazu einfach Rechtsklick auf betreffende Achse -> Achse formatieren...-> Achsenoptionen -> Einheiten -> Hauptstriche und dort trägst du dann den gewünschten Wert ein.

Deine Frage bezüglich "Punkte zeichnen" habe ich leider nicht verstanden. Wenn du das Minimum/Maximum der Achse fest vorgibst, endet die Achse genau an dem festgelegten Wert.

Sterndeuter · 10. Januar 2020

Ah ok, wenn man die Achse formatiert, bleibt die Formatierung auch nach Neuberechnung erhalten. Perfekt!

Die Enden der Achsen möchte ich gerne so haben, wie auf der unteren Zeichnung im Anhang. Excel macht es so wie auf der oberen Zeichnung, was ich aus mehreren Gründen unschön finde:
- Die Markierungen am Ende bei den Pfeilen sind nicht gut zu sehen.
- Die Achsen gehen nach den letzten Markierungen noch weiter, es sind schließlich "Zahlenstrahlen" und nicht Strecken.

Außerdem hätte ich gerne den Ursprung so markiert, wie in meinen Zeichnungen (also die 0 mittig auf dem Achsenkreuz, nicht wie bei Excel zweimal daneben). Geht das?

Beverly · 10. Januar 2020

Zu den Markierungen/Pfeilen: dann müsste das Maximum der Achsen anders eingestellt werden als vorgegeben, weshalb dadurch die Gitternetzlinien nicht mehr auf den Teilstrichen liegen, die du durch Vorgabe des Maximums erzielen willst - ich würde dir empfehlen, einfach mal von Hand zu testen, wie das Diagramm dann aussieht.

Zur Markierung des 0-Wertes: dazu musst du das Zahlenformat der Achsenbeschriftung auf Benutzerdefiniert #,##0;-#,##0; einstellen, sodass die 0 nicht angezeigt wird, und auf den 0-Punkt ein Textfeld einfügen. Du hast dann aber ein Problem, wenn der Absolutwert von Minimum und Maximum der Achse nicht identisch vorgegeben werden, weil sich dann nach Codeausführung logischerweise der Schnittpunkt der Achsen innerhalb des Diagramms verschiebt, das Textfeld jedoch an der ursprünglichen Position bleibt.

Sterndeuter · 23. Januar 2020

Liebe Karin,

danke für die viele Hilfe, jetzt ist die Datei fast perfekt!

Die letzte Anpassung des Codes für das leere Koordinatensystem macht nun folgendes: Es wird bei jedem Klick auf "Berechnen" ein neues leeres Koordinatensystem erstellt, allerdings stehen da drei Punkte immer drin: (0|0) wird rot markiert, (2|y-min) und (3|y-max) werden blau markiert (min und max stehen hier für den Minimal/Maximalwert, der für die y-Achse definiert wurde). Kann man das irgendwie ändern?

LG

Beverly · 23. Januar 2020

Hi,

das kann ich irgendwie nicht nachvollziehen - bei mir ist nur 1 Punkt da bei 0/0

Sterndeuter · 23. Januar 2020

Hier mal ein Screenshot. Und die Datei im Anhang.

Beverly · 23. Januar 2020

Wenn der Cursor bei Diagrammerstellung in einer Zelle mit einem Wert steht oder in deren angrenzenden Zellen Werte stehen, wird dies von Excel automatisch als ein Wertebereich gewertet und deshalb als Datenreihe(n) ins Diagramm eingefügt - und genau das ist bei dir der Fall (bei mir dagegen nicht, weil der Cursor sich weit weg von eventuellen gefüllten Zellen befand). Dass bereits eine Datenreihe vorhanden ist hättest du aber auch selbst rausfinden können, wenn du mal unter Daten auswählen... nachgeschaut hättest. *wink.gif*

Also müssen eventuell entstandene Datenreihen sicherheitshalber zuerst gelöscht werden:

Code:

Sub LeeresDia()
Dim lngReihe As Long
With ActiveSheet.Shapes.AddChart2(240, xlXYScatter, Range("D1").Left, 0, 500, 400).Chart
.HasTitle = False
If Range("B2") "" Then .Axes(xlCategory).MinimumScale = Range("B2")
If Range("B3") "" Then .Axes(xlCategory).MaximumScale = Range("B3")
If Range("B6") "" Then .Axes(xlValue).MinimumScale = Range("B6")
If Range("B7") "" Then .Axes(xlValue).MaximumScale = Range("B7")
If .SeriesCollection.Count > 0 Then
For lngReihe = .SeriesCollection.Count To 1 Step -1
.SeriesCollection(lngReihe).Delete
Next lngReihe
End If
With .SeriesCollection.NewSeries
.XValues = "={0}"
.Values = "={0}"
End With
End With
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Sterndeuter · 23. Januar 2020

Vielen Dank, liebe Karin, für deine Mühe! Ich setze dann das Thema mal als erldigt.

LG, Daniel

Office: (Office 2013) Polynom zeichnen

Polynom zeichnen

Polynom zeichnen

Polynom zeichnen

Polynom zeichnen

Polynom zeichnen - Similar Threads - Polynom zeichnen

Wertetabelle automatisch erstellen; Graph zeichnen

Polynomkoeffizienten ^0 bis ^9 in 10 Zellen nebeneinander darstellen

Zeichnen oder Bearbeiten einer Freihandform

Polynom-Fit mit RGP: Randbedingungen einhalten

Zeichnen auf Folien während einer Präsentation

Zeichnen/Kommentieren im geteilten Bildschirm

Hintergrund weich zeichnen steht nicht zur Verfügung