AW: Aus einer Tabelle einzelne Diagramme erstellen
05.12.2006 15:38:22
fcs
Hallo Ralph,
ich hatte mir auch schon ein paar Gedanken zur Lösung gemacht.
Habe einen etwas anderen Weg als Chris gewählt.
Lege in der Datei ein Diagramm als Muster an, Registername: MusterDiag. In diesem Diagramm muss du auch eine Datenreihe für den Letzten Einkaufspreis anlegen, wobei du für die Werte nur eine einzelne Zelle angibst.
Mein Makro kopiert dann dieses Muster für jede Roh.-Nr. und erstzt die Daten für die Datenreihen und den Diagramm-Titel.
Der Vorteil, du kannst das Diagramm speziell nach deinen Wünschen formatieren. In jeder Kopie bleiben die Formatierungen erhalten, und du bist nicht auf die Standardformatierungen von Excel begrenzt.
Das Problem bei Chris-Vorschlag könnte sein, dass in deinem Original der Name der Tabelle mit den Daten Sonderzeichen wie z.B. Leerzeichen, Punkte etc. enthält. Dann müssen die Tabellennamen für die Datenbereiche in Hochkomma gesetzt werden. Die CodeZeilen müßten dann entsprechend angepaßt werden.
Deine Datei mit Code: https://www.herber.de/bbs/user/38747.xls
Gruß
Franz
Sub DiagrammeErzeugen()
' DiagrammeErzeugen Makro
' Diagramme erzeugen pro Roh-Nr.
Dim wks As Worksheet, Diag As Chart, ZeileA As Long, ZeileE As Long, Zeile As Long
Set wks = ActiveWorkbook.Worksheets("Tabelle1") 'Tabellenblatt mit Daten
ZeileA = 2 '1. Zeile mit DiagrammDaten
Application.ScreenUpdating = False
With wks
For Zeile = ZeileA To .Cells(.Rows.Count, 2).End(xlUp).Row
'LetzteZeile zur Roh-Nr bestimmen
Do Until .Cells(Zeile + 1, 2) <> .Cells(ZeileA, 2)
Zeile = Zeile + 1
Loop
ZeileE = Zeile
Sheets("MusterDiag").Copy After:=Sheets(ActiveWorkbook.Sheets.Count)
Set Diag = ActiveChart
With Diag
'DatenReihe für Durchschnittspreis setzen
.SeriesCollection(1).XValues = "='" & wks.Name & "'!R" & ZeileA & "C1:R" & ZeileE & "C1"
.SeriesCollection(1).Values = "='" & wks.Name & "'!R" & ZeileA & "C4:R" & ZeileE & "C4"
.SeriesCollection(1).Name = "='" & wks.Name & "'!R" & ZeileA & "C2:R" & ZeileA & "C3"
'DatenReihe für Letzten Einkaufspreis setzen
.SeriesCollection(2).Values = "='" & wks.Name & "'!R" & ZeileA & "C5"
'Diagrammtitel einfügen
.HasTitle = True
.ChartTitle.Characters.Text = wks.Cells(ZeileA, 2) & " " & wks.Cells(ZeileA, 3)
.Deselect
End With
'Registernamen = Roh-Nr. setzen
Diag.Name = .Cells(ZeileA, 2)
ZeileA = ZeileE + 1 'Anfangszeile fürs nächste Diagramm setzen
Next Zeile
End With
Application.ScreenUpdating = False
End Sub