AW: Diagramme schnell erstellen
13.01.2011 15:32:45
Beverly
Hi Maris,
das Ganze ist eine sehr komplexe Aufgabe und der Aufwand, alles per VBA lösen zu wollen, übersteigt die Hilfe in einem Forum - deshalb ist hier auch Handarbeit von deiner Seite gefragt. Erstelle in jedem Tabellenblatt für jede "Rubrik" je 1 Diagramm mit dem 1. Wertebereich und kopiere (oder verschiebe) dann alle an die betreffende Stelle im Tabellenblatt "Charts", und zwar so, dass die linke obere Ecke genau so positioniert ist wie bei dem dort bereits vorhandenen Diagramm - also jeweils 2 Zeilen unter und genau an der linken Kante der Zelle in Spalte C, die den Tabellenblattnamen enthält. Markiere dann im Tabellenblatt "Charts" jeweils das äußerste linke Diagramm und lasse folgenden Code ablaufen:
Sub DiasErstellen()
Dim intDia As Integer
Dim intReihe As Integer
Dim intZaehler As Integer
Dim strBereich As String
Dim strBereichNeu As String
Dim varTyp As Variant
Dim chrDiagramm As ChartObject
On Error Resume Next
varTyp = Selection.Name
On Error GoTo 0
If varTyp = "Diagramm" Then
Set chrDiagramm = ActiveChart.Parent
intZaehler = 2
Application.ScreenUpdating = False
For intDia = 2 To 8
chrDiagramm.Copy
ActiveSheet.Paste
With ActiveSheet.ChartObjects(ActiveSheet.ChartObjects.Count)
.Top = chrDiagramm.Top
.Left = chrDiagramm.Left + chrDiagramm.Width * (intDia - 1)
For intReihe = 1 To .Chart.SeriesCollection.Count
strBereich = .Chart.SeriesCollection(intReihe).Formula
strBereich = Mid(strBereich, InStrRev(strBereich, "!") + 1)
strBereich = Left(strBereich, InStrRev(strBereich, ",") - 1)
strBereich = Application.Substitute(strBereich, Range(strBereich).Row, _
Range(strBereich).Row)
strBereichNeu = Application.Substitute(strBereich, Range(strBereich).Row, _
Range(strBereich).Row + intZaehler)
.Chart.SeriesCollection(intReihe).Formula = Application.Substitute(.Chart. _
SeriesCollection(intReihe).Formula, strBereich, strBereichNeu)
strBereich = Left(.Chart.SeriesCollection(intReihe).Formula, InStr(.Chart. _
SeriesCollection(intReihe).Formula, ",") - 1)
strBereich = Mid(strBereich, InStr(strBereich, "$"))
strBereichNeu = Application.Substitute(strBereich, Range(strBereich).Row, _
Range(strBereich).Row + intZaehler)
.Chart.SeriesCollection(intReihe).Formula = Application.Substitute(.Chart. _
SeriesCollection(intReihe).Formula, "!" & strBereich & ",", "!" & strBereichNeu & ",")
strBereich = Left(.Chart.SeriesCollection(intReihe).Formula, InStr(.Chart. _
SeriesCollection(intReihe).Formula, ",") - 1)
strBereich = Range(Mid(strBereich, InStr(strBereich, "(") + 1)).Parent.Name
.Chart.SeriesCollection(intReihe).Formula = Application.Substitute(.Chart. _
SeriesCollection(intReihe).Formula, "'" & strBereich & "'", chrDiagramm.TopLeftCell.Offset(-2, 0))
Next intReihe
strBereich = Left(.Chart.SeriesCollection(1).Formula, InStr(.Chart. _
SeriesCollection(1).Formula, ",") - 1)
strBereich = Range(Mid(strBereich, InStr(strBereich, "(") + 1))
.Chart.ChartTitle.Caption = Left(.Chart.ChartTitle.Caption, InStr(.Chart. _
ChartTitle.Caption, " ")) & strBereich
strBereich = Left(.Chart.SeriesCollection(2).Formula, InStr(.Chart. _
SeriesCollection(2).Formula, ",") - 1)
strBereich = Range(Mid(strBereich, InStr(strBereich, "(") + 1))
.Chart.ChartTitle.Caption = .Chart.ChartTitle.Caption & " & " & strBereich
End With
intZaehler = intZaehler + 2
Next intDia
Set chrDiagramm = Nothing
Application.ScreenUpdating = True
Else
MsgBox "Kein Diagramm ausgewählt"
End If
End Sub
Daraufhin sollten "Zeilenweise" angeordnet noch 7 weitere Diagramme erstellt werden, die sich auf das selbe Tabellenblatt und die selbe "Rubrik" beziehen, nur dass der Wertebereich jeweils um 2 Zeilen nach unten versetzt ist.
