Diagrammlegende

Sub Diagramm()
' Formatierung der Parameter für das Diagramm
'Dimensionierung der Parameter
Dim D1 As String
Dim D2 As String
Dim D3 As String
Dim sDatum As String
Dim PD1 As Range
Dim PD2 As Range
Dim PD3 As Range
Dim K1 As Double
Dim K2 As Double
Dim K3 As Double
Dim K4 As Double
Dim Auslastung1 As Double
Dim Auslastung2 As Double
Dim Auslastung3 As Double
Dim Auslastung4 As Double
Dim Maximum As Integer
Dim xArr As Variant
Dim yArr()
Dim Abzisse(0, 0 To 365)
Dim Ordinate(0, 0 To 365)
Dim DatumFormat(0, 0 To 365)
Dim rng As Range
Dim n As Long
Dim j As Long
Dim iRows As Long
' Datensammlung fürs Diagramm
'Aktivierung des zu verändernden Sheets
ActiveSheet.Activate
' Bestimmung der Zeile bis zur gefüllten Reihe
For z = 4 To 100
For s = 2 To 2
If IsEmpty(Range(Worksheets("RTPS-Matrix").Cells(z, s), Worksheets("RTPS-Matrix"). _
Cells(z, s)).Value) = True Then
iRows = Cells(z, 2).End(xlUp).Row
Exit For
End If
Next s
Next z
'Schleife für alle Mitarbeitenden in der Liste der Tabelle
For n = 1 To iRows - 3
'Festlegung des Bereiches für die Daten (Pl. Datum)
Set rng = Union(Cells(n + 3, 9), Cells(n + 3, 12), Cells(n + 3, 15))
'Sortierung der Werte nach aufsteigendem Datum + Integrationnicht ausgefüllter Textboxen
D1 = CDate(WorksheetFunction.Small(rng, 1))
On Error Resume Next
Set PD1 = rng.Find(What:=CDate(WorksheetFunction.Small(rng, 1)), LookAt:=xlWhole)
On Error Resume Next
D2 = CDate(WorksheetFunction.Small(rng, 2))
On Error Resume Next
Set PD2 = rng.Find(What:=CDate(WorksheetFunction.Small(rng, 2)), LookAt:=xlWhole)
On Error Resume Next
D3 = CDate(WorksheetFunction.Small(rng, 3))
On Error Resume Next
Set PD3 = rng.Find(What:=CDate(WorksheetFunction.Small(rng, 3)), LookAt:=xlWhole)
On Error Resume Next
' Festlegung der Zugehörige Auslastung
K1 = PD1.Offset(0, -2)              'Auslastung des kleinsten Datums
K2 = PD2.Offset(0, -2)              'Auslastung des mittleren Datums
K3 = PD3.Offset(0, -2)              'Auslastung des größten Datums
K4 = ActiveSheet.Cells(n + 3, 5)    'Auslastung der Daueraufgabe
' Berechnung der Auslastung für die Darstellung im Diagramm
Auslastung1 = K1 + K2 + K3 + K4
Auslastung2 = K2 + K3 + K4
Auslastung3 = K3 + K4
Auslastung4 = K4
' ändert Arrays für die Nutzung im Diagramm
For i = 1 To 365
Abzisse(0, i) = DateAdd("d", i, Date)
Ordinate(0, i) = Auslastung1
Next i
' Anpassung des Arrays für das Diagramm
i = WorksheetFunction.Match(D1, Abzisse, 0)
sDatum = Abzisse(0, i - 1)
For i = i To 365
Ordinate(0, i) = Auslastung2
Next i
'Bis 2. Datum
i = WorksheetFunction.Match(D2, Abzisse, 0)
sDatum = Abzisse(0, i - 1)
For i = i To 365
Ordinate(0, i) = Auslastung3
Next i
'Bis 3. Datum
i = WorksheetFunction.Match(D3, Abzisse, 0)
sDatum = Abzisse(0, i - 1)
For i = i To 365
Ordinate(0, i) = Auslastung4
Next i
' Anpassung des Formates des Datums an das Gewünschte, hier: "Short Date"
For i = 1 To 365
DatumFormat(0, i) = Format(Abzisse(0, i), "Short Date")
Next i
'Genutzte Arrays für das Diagramm
xArr = DatumFormat()
ReDim Preserve yArr(0, n)
yArr(0, n) = Ordinate()
Next n
' Auswahl der Tabelle und des Diagrammtypes
With ActiveSheet
.Shapes.AddChart2(276, xlAreaStacked).Select
.Application.CutCopyMode = False
End With
With ActiveChart
' Festlegung der Daten für das Diagramm
For n = 1 To iRows - 3
.SeriesCollection.NewSeries
.SeriesCollection(n).Name = Cells(n + 3, 2)
.SeriesCollection(n).Values = yArr(0, n)
.SeriesCollection(n).XValues = xArr
' Festlegung der Achse für die Legende
.ChartArea.Select
.SetElement (msoElementLegendRight)
.Legend.Select
.Legend.LegendEntries(n).Select
Next n
End With
End Sub