Habe mal etwas weiter rumprobiert. Die Grafik wird mittlerweile super erstellt. Versuche dies jetzt noch etwas zu automasieren und zwar würde ich gerne eine Schleife einbauen die Endet wenn in Zeile 12 kein Wert/Wort mehr steht.

Außerdem soll nach jedem durchlauf. die ActiveCell auf 29 zurück gesetzt werden und dann 3 Spalten nach rechts gesetzt werden damit das Makro wieder durchlaufen kann.

Hat wer eine Idee

Sub Grafik()
'
' Grafik Makro
'
Dim rng As Range

'
    ActiveCell.Select
    ActiveCell.FormulaR1C1 = "=AVERAGE(R[-16]C:R[-14]C)"
    ActiveCell.Select
    Selection.Copy
    ActiveCell.Offset(3, 0).Select
    ActiveSheet.Paste
    ActiveCell.Offset(3, 0).Select
    ActiveSheet.Paste
    ActiveCell.Offset(3, 0).Select
    ActiveSheet.Paste
    ActiveCell.Offset(3, 0).Select
    ActiveSheet.Paste
    ActiveSheet.Shapes.AddChart2(240, xlXYScatter).Select
Set rng = ActiveCell
With ActiveChart
        .SeriesCollection.NewSeries
        .FullSeriesCollection(1).Name = "=""Einzelwerte"""
        .FullSeriesCollection(1).XValues = "='Tabelle 1'!$B$29:$B$43"
        .FullSeriesCollection(1).Values = Range(rng.Offset(-29, 0), rng.Offset(-14, 0))
        .SeriesCollection.NewSeries
        .FullSeriesCollection(2).Name = "=""Mittelwert"""
        .FullSeriesCollection(2).XValues = "='Tabelle 1'!$C$31:$C$43"
        .FullSeriesCollection(2).Values = Range(rng, rng.Offset(-12, 0))
        .PlotArea.Select
        .FullSeriesCollection(2).Trendlines.Add Type:=xlLinear, Forward _
        :=0, Backward:=0, DisplayEquation:=0, DisplayRSquared:=0, Name:= _
        "Linear (Mittelwert)"
        .FullSeriesCollection(2).Trendlines(1).Select
            Selection.DisplayEquation = True
            Selection.DisplayRSquared = True
            Application.CommandBars("Format Object").Visible = False
        .FullSeriesCollection(2).Trendlines(1).DataLabel.Select
             Selection.Left = 237.787
             Selection.Top = 34.767
    End With

End Sub

Tim