XY Diagramme aus 2 Tabellenblättern VBA

Hallo,
ich suche ein Makro, dass mir aus einer Tabelle Diagramme automatisch erstellt. Die Datei besteht aus 2 Tabellenblättern, die identisch aufgebaut sind, jedoch einmal mit bereinigten und unbereinigten Messwerten versehen sind.
Eine Testdatei ist im Anhang (bzw ein Bild, wie es sein soll).
Nun will ich auf einem drittem Tabellenblatt (Diagramme) mir zu jedem Messwert ein Diagramm zeigen lassen.
Auf der X-Achse soll das Datum stehen, auf der Y-Achse die Messwerte.
Jedes Diagramm soll 2 Kurven haben. Einmal die unbereinigten Werte aus Blatt 1 und einmal die bereinigten aus Blatt 2.
Also: Diagramm n: X:Achse: Datum, Y-Achse: Wert(n) bereinigt // Wert (n) unbereinigt
Ich habe mich mal mit dem Makro Rekorder versucht, allerdings entstehen dabei Fehlermeldungen oder es funktioniert nicht richtig.
Anbei der Code. Ich habe mir überlegt, die Werte erst rüber zukopieren, das Diagramm dann damit zu erstellen.
Allerdings übernimmt er nur 1 Diagramm und der ganze Weg dahin ist ein ziemliches Gefummel, da ich einige Makros mehrmals ausführen muss.
Für etwaige Lösungsvorschläge bin ich sehr dankbar.

Sub Datum_kopieren()
' Datum_kopieren Makro Hinweis: Blatt mit Namen "Hilfswerte Diagramme" erstellen
Range("A11").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Hilfswerte Diagramme").Select
Range("A1").Select
ActiveSheet.Paste
End Sub

Sub werte_kopieren()
' werte_kopieren Makro HINWEIS: B1 Im Blatt Hilfswerte auswählen, ersten Startwert im  _
Tabellenblatt markieren
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Hilfswerte Diagramme").Select
ActiveSheet.Paste
Sheets("Werte bereinigt").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hilfswerte Diagramme").Select
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(0, 1).Range("A1").Select
Sheets("Werte bereinigt").Select
ActiveCell.Offset(0, 1).Range("A1").Select
Application.CutCopyMode = False
Sheets("Werte unbereinigt").Select
ActiveCell.Offset(0, 1).Range("A1").Select
End Sub



Sub verschieben()

'

' verschieben Makro

'

'

Selection.EntireColumn.Insert , CopyOrigin:=xlFormatFromLeftOrAbove

ActiveCell.Offset(0, -3).Range("A1").Select

Range(Selection, Selection.End(xlDown)).Select

Selection.Copy

ActiveCell.Offset(0, 3).Range("A1").Select

ActiveSheet.Paste

ActiveCell.Offset(0, 3).Range("A1").Select

End Sub



Sub Diagramm()

'

' Diagramm Makro

'

'

ActiveCell.Range("A1:C1").Select

Range(Selection, Selection.End(xlDown)).Select

ActiveSheet.Shapes.AddChart.Select

ActiveChart.ChartType = xlXYScatterLinesNoMarkers

ActiveChart.SetSourceData Source:=Range( _

"'Hilfswerte Diagramme'!$A$1:$C$105408")

ActiveChart.Parent.Cut

Sheets("Diagramme").Select

ActiveSheet.Paste

Sheets("Hilfswerte Diagramme").Select

ActiveCell.Offset(0, 3).Range("A1").Select

End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Diagramme() Dim ws As Worksheet, WsDiagramm As Worksheet, WsExists As Boolean Dim Messwerte As Integer, AktChart As Chart, Top As Integer 'Pruefen, ob Abeitsblatt schon existiert, ansonsten anlegen For Each ws In ThisWorkbook.Worksheets If ws.Name = "Diagramme" Then Set WsDiagramm = ws WsExists = True End If Next ws If WsExists = False Then Set WsDiagramm = Sheets.Add(after:=Sheets("Werte bereinigt")) WsDiagramm.Name = "Diagramme" End If 'Diagramme erstellen pro Messwert For Messwerte = 1 To 3 Set AktChart = WsDiagramm.Shapes.AddChart2(227, xlLine, 1, Top, , 200).Chart With AktChart .ChartTitle.Text = "Messwert " & Messwerte .SeriesCollection.NewSeries .FullSeriesCollection(1).XValues = Sheets("Werte unbereinigt").Range("$A$11:$A$41") .FullSeriesCollection(1).Name = "Werte unbereinigt" .FullSeriesCollection(1).Values = Sheets("Werte unbereinigt").Range("$C$11:$C$41").Offset( _ 0, Messwerte - 1) .SeriesCollection.NewSeries .FullSeriesCollection(2).Name = "Werte bereinigt" .FullSeriesCollection(2).Values = Sheets("Werte bereinigt").Range("$C$11:$C$41").Offset(0, _ Messwerte - 1) End With Top = Top + 210 Next Messwerte End Sub

Sub Diagramme wird dabei gelb angezeigt. Ich hab mal etwas dazu gegoogelt und anscheinend kann Excel 2010 den Befehl noch nicht _ verarbeiten, sondern nur "SeriesCollection" Bekomme aber wieder eine Fehlermeldung "Laufzeitfehler 91" : Blockvariable oder with- _ Blockvariable nicht festgelegt". So sieht der Code grad aus 'Diagramme erstellen pro Messwert For Messwerte = 1 To 3 Set AktChart = WsDiagramm.Shapes.AddChart2(227, xlLine, 1, Top, , 200).Chart With AktChart .HasTitle = True .ChartTitle.Text = "Messwert & Messwerte" .SeriesCollection.NewSeries .SeriesCollection(1).XValues = Sheets("Werte unbereinigt").Range("$A$11:$A$41") .SeriesCollection(1).Name = "Werte unbereinigt" .SeriesCollection(1).Values = Sheets("Werte unbereinigt").Range("$C$11:$C$41").Offset( _ 0, Messwerte - 1) .SeriesCollection.NewSeries .SeriesCollection(2).Name = "Werte bereinigt" .SeriesCollection(2).Values = Sheets("Werte bereinigt").Range("$C$11:$C$41").Offset(0, _ Messwerte - 1) End With Top = Top + 210 Next Messwerte End Sub

Sub Diagramme() Dim ws As Worksheet, WsDiagramm As Worksheet, WsExists As Boolean Dim Messwerte As Integer, AktChart As Chart, Top As Integer 'Pruefen, ob Abeitsblatt schon existiert, ansonsten anlegen For Each ws In ThisWorkbook.Worksheets If ws.Name = "Diagramme" Then Set WsDiagramm = ws WsExists = True End If Next ws If WsExists = False Then Set WsDiagramm = Sheets.Add(after:=Sheets("Werte bereinigt")) WsDiagramm.Name = "Diagramme" End If 'Diagramme erstellen pro Messwert For Messwerte = 1 To 3 Set AktChart = WsDiagramm.Shapes.AddChart2(227, xlLine, 1, Top, , 200).Chart With AktChart .HasTitle = True .ChartTitle.Text = "Messwert & Messwerte" .SeriesCollection.NewSeries .SeriesCollection(1).XValues = Sheets("Werte unbereinigt").Range("$A$11:$A$") .SeriesCollection(1).Name = "Werte unbereinigt" .SeriesCollection(1).Values = Sheets("Werte unbereinigt").Range("$C$11:$C$").Offset( _ 0, Messwerte - 1) .SeriesCollection.NewSeries .SeriesCollection(2).Name = "Werte bereinigt" .SeriesCollection(2).Values = Sheets("Werte bereinigt").Range("$C$11:$C$").Offset(0, _ Messwerte - 1) End With Top = Top + 210 Next Messwerte End Sub

Sub Diagramme() Dim ws As Worksheet, WsDiagramm As Worksheet, WsExists As Boolean Dim Messwerte As Integer, AktChart As Chart, Top As Integer lzA = Cells(Rows.Count, 1).End(xlUp).Row lzC = Cells(Rows.Count, 3).End(xlUp).Row 'Pruefen, ob Abeitsblatt schon existiert, ansonsten anlegen For Each ws In ThisWorkbook.Worksheets If ws.Name = "Diagramme" Then Set WsDiagramm = ws WsExists = True End If Next ws If WsExists = False Then Set WsDiagramm = Sheets.Add(after:=Sheets("Werte bereinigt")) WsDiagramm.Name = "Diagramme" End If 'Diagramme erstellen pro Messwert For Messwerte = 1 To 3 Set AktChart = WsDiagramm.Shapes.AddChart2(227, xlLine, 1, Top, , 200).Chart With AktChart .HasTitle = True .ChartTitle.Text = "Messwert & Messwerte" .SeriesCollection.NewSeries .SeriesCollection(1).XValues = Sheets("Werte unbereinigt").Range("A11:A&lzA") .SeriesCollection(1).Name = "Werte unbereinigt" .SeriesCollection(1).Values = Sheets("Werte unbereinigt").Range("C11:C&lzC").Offset(0, _ Messwerte - 1) .SeriesCollection.NewSeries .SeriesCollection(2).Name = "Werte bereinigt" .SeriesCollection(2).Values = Sheets("Werte bereinigt").Range("C11:C&lzC").Offset(0, _ Messwerte - 1) End With Top = Top + 210 Next Messwerte End Sub

Sub DiagrammErstellen() Dim i, lastrow, X, Y, spalten, cht, l, r spalten = Array("C", "D", "E", "F", "G", "H") For i = 0 To UBound(spalten) lastrow = Cells(Rows.Count, 1).End(xlUp).Row X = "A2:A" & lastrow Y = spalten(i) & "2:" & spalten(i) & lastrow Set cht = ActiveSheet.Shapes.AddChart cht.Chart.ChartType = xlXYScatter cht.Chart.SetSourceData Source:=Sheets(1).Range(X & "," & Y) cht.Chart.SeriesCollection(1).Name = "='" & ActiveSheet.Name & "'!$" & spalten(i) & "$1" cht.Width = 180 'Breite des Diagramms cht.Height = 150 'Höhe If i Mod 2 = 0 Then cht.Left = Range("O2").Left 'O2 linke obere Ecke der Diagramme aus Spalte B/F/G cht.Top = Range("O2").Offset(l * 14, 0).Top l = l + 1 Else cht.Left = Range("S2").Left 'S2 linke obere Ecke der Diagramme aus Spalte C/G/K cht.Top = Range("S2").Offset(r * 14, 0).Top r = r + 1 End If Next End Sub

Hallo Alex
anbei eine nachgebaute Beispiel Datei von mir mit einer Makro Lösung zu einem früheren Code.
Den letzten Code habe ich laufen lassen, du siehst ein Ergebnis, mir ist aber unklat ob das gewünscht ist?
Auf der unteren Achse sehe ich die Zahlen 8, 5, 10 statt Datum. Deswegen bin ich in umklaren was du anzeigst?
Im Blatt "Diagramm Test" findest du den Code aus deiner ersten Anfrage, der funktioniert jetzt auch.
Wenn du wissen willst was man bei Range(Selection) richtig bösartig falsch machen kann schau dir bitte deinen eigenen Code aus dem Makro Diagramm im Sheet "Hilfswerte Diagramme" an! Da ging es ums kopieren von Daten aus "Werte unbearbeitet" und "bereinigt".
War auch für mich eine nette amüsante Überraschung als ich diesen Kopiervorgang mit Select rekonstruierte!!
Im Blatt Diagramm findest du den Code von Daniel, den ich aendern muste, weil der Befehl "Shapes.AddChart2" auf meinem PC nicht funktioniert. Kann sein das er erst ab Excel 2010 klappt? Dieses Makro findest du im Modul2_2 und alle Werte, Höhe, Breite, Top und Left auf dem Bildschirm kannst du nach belieben selbst einstellen.
Bei dem neuen Code ist mein Vorschlag durch 2 For Next Schleifen 3+3 zu machen! Drei Diagramme untereinander für bereinigte Werte, daneben die unbereinigten. So kannst du 1:1 vergleichen! Bei diesem System must du den Vergleichswert über Kreuz suchen!
Wenn du mir sagst welche Daten im neuen Code wohin sollen bringen wir den evtl. auch ans Laufen.
Jetzt warte ich erst mal deine Rückmeldung ab.
mfg Piet
https://www.herber.de/bbs/user/126721.xlsm

Beliebteste Forumthreads (12 Monate)

XY Diagramme aus 2 Tabellenblättern VBA

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

319 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

XY Diagramme aus 2 Tabellenblättern VBA

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

319 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread