BTW: wenn Du die Diagramme gleich trenenn willst, nimm folgenden Code:
Option Explicit
Sub neu()
With ActiveSheet
Dim BereichB As String
Dim BereichA As String
Dim BereichF As String
Dim CRT As Long
'erstes Diagramm
BereichB = "$B2:$B$" & Application.WorksheetFunction.CountA(.Range("B:B"))
BereichB = BereichB & ",$D$2:$D$" & Application.WorksheetFunction.CountA(.Range("D:D"))
Charts.Add
ActiveChart.ChartType = xlLineMarkers
ActiveChart.SetSourceData Source:=Sheets("Tabelle1").Range(BereichB), PlotBy:=xlColumns
ActiveChart.Location Where:=xlLocationAsObject, Name:="Tabelle1"
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "TestB"
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "KreuzdiagrammB"
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Auf- und AbwärtsB"
End With
'zweites Diagramm
BereichA = "$A2:$A$" & Application.WorksheetFunction.CountA(.Range("A:A"))
BereichA = BereichA & ",$B$2:$B$" & Application.WorksheetFunction.CountA(.Range("B:B"))
BereichA = BereichA & ",$C$2:$C$" & Application.WorksheetFunction.CountA(.Range("C:C"))
BereichA = BereichA & ",$D$2:$D$" & Application.WorksheetFunction.CountA(.Range("D:D"))
Charts.Add
ActiveChart.ChartType = xlLineMarkers
ActiveChart.SetSourceData Source:=Sheets("Tabelle1").Range(BereichA), PlotBy:=xlColumns
ActiveChart.Location Where:=xlLocationAsObject, Name:="Tabelle1"
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "TestA"
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "KreuzdiagrammA"
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Auf- und AbwärtsA"
End With
'drittes Diagramm
BereichF = "$F2:$F$" & Application.WorksheetFunction.CountA(.Range("F:F"))
BereichF = BereichB & ",$G$2:$G$" & Application.WorksheetFunction.CountA(.Range("G:G"))
BereichF = BereichB & ",$H$2:$H$" & Application.WorksheetFunction.CountA(.Range("H:H"))
Charts.Add
ActiveChart.ChartType = xlLineMarkers
ActiveChart.SetSourceData Source:=Sheets("Tabelle1").Range(BereichF), PlotBy:=xlColumns
ActiveChart.Location Where:=xlLocationAsObject, Name:="Tabelle1"
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "TestF"
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "KreuzdiagrammF"
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Auf- und AbwärtsF"
End With
'Diagramme trennen
For CRT = 1 To .ChartObjects.Count
.ChartObjects(CRT).Activate
ActiveChart.ChartArea.Select
.Shapes(CRT).IncrementLeft 300#
Select Case CRT
Case 1
.Shapes(CRT).IncrementTop -250#
Case 2
.Shapes(CRT).IncrementTop 200#
Case 3
.Shapes(CRT).IncrementTop 590#
End Select
Next CRT
ActiveWindow.Visible = False
Windows(ThisWorkbook.Name).Activate
Range("A1").Select
End With
End Sub
Severus |