Originalmappe nun doch anders?!
22.07.2016 18:59:27
Beverly
Hi Mathias,
als ich dir geschrieben habe, dass du eine Beispielmappe mit dem genauen Tabellenaufbau hochladen sollst, habe ich mir schon etwas dabei gedacht, aber du hast es ja besser gewusst und deshalb sollte ich dich eigentlich mit dem Dilemma jetzt alleine lassen, denn ich habe viel Zeit für den ersten Code investiert, die nun für den Papierkorb war - wer arbeitet schon gerne umsonst, zumal man als Helfer hier seine Freizeit dafür hergibt?!
Sicher sieht es so aus, als ob der Code "nur" an einigen Stellen umzuschreiben und an die neuen Bedingungen anzupassen gewesen sei, aber außerdem musste auch wieder getestet werden und diese gesamte Zeit hätte ich mir sparen können, wenn mir gleich von Beginn an der tatsächliche Tabellenaufbau bekannt gewesen wäre. Lasse es dir bitte für die Zunkunft eine Lehre sein und erleichtere den Helfern die Arbeit, indem du gleich von Beginn an den richtigen Tabellenaufbau bereitstellst, zumal wenn man dich genau darum bittet.
Sub DiasKopieren()
Dim lngZeile As Long
Dim lngReihe As Long
Dim strFormel As String
Dim strXWerte As String
Dim strYWerte As String
Dim strName As String
Application.ScreenUpdating = False
For lngZeile = 16 To IIf(IsEmpty(Cells(Rows.Count, 5)), Cells(Rows.Count, 5).End(xlUp).Row, _
Rows.Count) Step 10
ActiveSheet.ChartObjects(1).Copy
ActiveSheet.Paste
With ActiveSheet.ChartObjects(ActiveSheet.ChartObjects.Count)
.Top = Cells(lngZeile, 21).Top
.Left = Cells(lngZeile, 21).Left
With .Chart
For lngReihe = 1 To .SeriesCollection.Count
strFormel = ActiveSheet.ChartObjects(ActiveSheet.ChartObjects.Count - 1). _
Chart.SeriesCollection(lngReihe).Formula
strYWerte = Split(strFormel, ",")(2)
strYWerte = Worksheets("Tabelle1").Range(strYWerte).Offset(10, 0).Address
strXWerte = Split(strFormel, ",")(1)
If Range(strXWerte).Row 5 Then
strXWerte = Split(strFormel, ",")(1)
strXWerte = Range(strXWerte).Offset(10, 0).Address
strName = Split(strFormel, ",")(0)
strName = Mid(strName, InStr(strName, "!") + 1)
.SeriesCollection(lngReihe).XValues = Worksheets("Tabelle1").Range( _
strXWerte)
Else
strName = Cells(Range(strYWerte).Row, 5).Address
End If
.SeriesCollection(lngReihe).Values = Worksheets("Tabelle1").Range(strYWerte) _
.SeriesCollection(lngReihe).Name = "=Tabelle1!" & strName
Next lngReihe
End With
End With
Next lngZeile
Application.ScreenUpdating = True
End Sub