Meine Lösung
28.03.2018 07:57:21
Burak
Für jedes Verlaufsdiagramm stehen die Werte in jeweils einer Spalte. Den Median berechne ich und schreibe ihn genauso oft wie oft die Werte des Diagramms vorkommen direkt darunter.
Also für Diagramm 1: 510 Werte, Median berechnen und 510 mal unter die 510 Werte schreiben.
Und dann diese 510 MEDIAN-Werte als zweite Linie in die Grafik einzeichnen.
median = Application.WorksheetFunction.Quartile(Columns(d + 25), 2)
For i = 1 To letzte
'Median berechnen
Cells(letzte + i, d + 25) = median
Next i
With ActiveChart
'Median mit einzeichnen
.SeriesCollection.NewSeries
.SeriesCollection(2).values = "='Linienauswertung - Grafiken'!" & Cells(letzte, d + 25). _
Address & ":" & Cells(medianletzte, d + 25).Address
End With
Und falls es jmd interessiert, hier nochmal der Code im Gesamten:
Sub verlaufsdiagramm()
'Variablendeklaration
Dim linie As String, barcode As Integer, bartest As String, szeile, ezeile, szeile2, ezeile2, _
lastRowInList As Long, rowHelper As Long, d As Integer, letzte As Long, median As Double, medianletzte As Long
'Makrobremsen lösen
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With ActiveSheet
'Blattschutz aufheben
.Unprotect
'Alle Diagramme löschen
If .ChartObjects.Count > 0 Then .ChartObjects.Delete
End With
'Spalten ab Spalte Z leeren
Columns(26).Resize(, 20).EntireColumn.Clear
'Startwert für Spaltenvariable
d = 1
'Usereingabe für Linie
linie = barcodewahl.liniebox
'Abbruch
If linie = "" Then Exit Sub
'Usereingabe für Barcode
bartest = barcodewahl.barcodebox
'Abbruchbedingung leer/nicht numerisch
If bartest = "" Or Not IsNumeric(bartest) Then
Unload barcodewahl
Exit Sub
End If
'Umwandlugn string in Integer
barcode = CInt(bartest)
'Eingabemaske ausblenden
Unload barcodewahl
'Letzte Zeile ermitteln
lastRowInList = Worksheets(linie).Range(Worksheets(linie).Range("A1").End(xlDown), Worksheets( _
linie).Range("A65536").End(xlUp)).Row
'Startwert für letzte Zeile
ezeile = 1
Do Until IsError(Application.Match(barcode, Worksheets(linie).Range("A" & ezeile + 1 & ":A" & _
lastRowInList), 0)) Or ezeile = lastRowInList
'Startzeile des Auftrags ermitteln
szeile = Application.Match(barcode, Worksheets(linie).Range("A" & ezeile + 1 & ":A" & _
lastRowInList), 0) + ezeile
'Rüstwechsel/1. Barcode rausfiltern
Do Until Worksheets(linie).Range("B" & szeile) Worksheets(linie).Range("B" & szeile + 1)
szeile = szeile + 1
Loop
ezeile = szeile
'Endzeile des Auftrags ermitteln
For rowHelper = ezeile + 1 To lastRowInList
'Zähle hoch bis zur ersten Nicht-Übereinstimmung des Barcodes
If Worksheets(linie).Cells(rowHelper, 1) = barcode Then
ezeile = rowHelper
Else
'Schleifenabbruch
Exit For
End If
Next
'Zeitwerte kopieren
Worksheets(linie).Range("E" & szeile + 1 & ":E" & ezeile).Copy Columns(d + 25)
letzte = ezeile - szeile
'Kopierte Zeitwerte in Minuten umwandeln
For i = 1 To letzte
Cells(i, d + 25).Value = Cells(i, d + 25).Value / 60
Next i
'Median berechnen
median = Application.WorksheetFunction.Quartile(Columns(d + 25), 2)
For i = 1 To letzte
'Median mehrfach eintragen
Cells(letzte + i, d + 25) = median
Next i
'Letzten Medianwert finden
medianletzte = ActiveSheet.Cells(Rows.Count, d + 25).End(xlUp).Row
'Zeitverlaufsdiagramm des Auftrags hinzufügen
ActiveSheet.Shapes.AddChart.Select
With ActiveChart
'Datenbereich auswählen
.SetSourceData Source:=Range(Cells(1, d + 25), Cells(ezeile - szeile, d + 25))
'X-Achsen-Werte festlegen
.SeriesCollection(1).XValues = "='" & linie & "'!$N$" & szeile + 1 & ":$N$" & ezeile
'Diagrammtyp Verlaufsdiagramm
.ChartType = xlLine
'Diagrammtitel anzeigen und beschriften
.SetElement (msoElementChartTitleAboveChart)
.ChartTitle.Text = "Linie " & linie & " - " & Left(barcode, 3) & "." & Right(barcode, 1) & " _
- Auftrag " & d & " - Stückzahl: " & (ezeile - szeile)
'Legende ausblenden
.HasLegend = False
'Intervalle festlegen
.Axes(xlValue).MajorUnit = 2
.Axes(xlCategory).TickLabelSpacing = ((ezeile - szeile) / 10) - 1
.Axes(xlCategory).TickMarkSpacing = (ezeile - szeile) / 10
'y -achsenbeschriftung
.SetElement (msoElementPrimaryValueAxisTitleHorizontal)
Selection.Left = 9
Selection.Top = 9
.Axes(xlValue, xlPrimary).AxisTitle.Text = "in min"
'Median mit einzeichnen
.SeriesCollection.NewSeries
.SeriesCollection(2).values = "='Linienauswertung - Grafiken'!" & Cells(letzte, d + 25). _
Address & ":" & Cells(medianletzte, d + 25).Address
'Hintergrund des Diagramms
With .PlotArea.Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent5
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0.8000000119
.Transparency = 0.6999999881
.Solid
End With
End With
'Y-Achsenbereich festlegen
With ActiveChart.Axes(xlValue)
.MinimumScale = 0
.MaximumScale = 20
End With
'Größe und Position der Diagramme
With ActiveSheet
'Position
.ChartObjects(d).Left = 5
.ChartObjects(d).Top = 755 + ((d - 1) * 370)
'Größe
.ChartObjects(d).Height = 370
.ChartObjects(d).Width = 980
End With
'nächste Spalte
d = d + 1
Loop
End Sub