AW: Diagramm erstellen VBA
06.08.2012 11:32:16
Beverly
Hi Andreas,
Private Sub CommandButton1_Click()
Dim lngZaehler As Long
Dim lngZeile As Long
Dim dblPruefWert As Double
Dim chrDia As Chart
Dim arrDias()
' Bildschirmaktualisierung ausschalten
Application.ScreenUpdating = False
' wenn bereits Diagramblätter vorhanden
If ActiveWorkbook.Charts.Count > 0 Then
' Schleife über alle Diagrammblätter
For Each chrDia In ActiveWorkbook.Charts
ReDim Preserve arrDias(0 To lngZaehler)
' Diagrammname ind Array schreiben
arrDias(lngZaehler) = chrDia.Name
lngZaehler = lngZaehler + 1
Next chrDia
' Excel-interne Hinweise abschalten
Application.DisplayAlerts = False
' alle Diagrammblätter löschen
Charts(arrDias).Delete
' Excel-interne Hinweise einschalten
Application.DisplayAlerts = True
End If
lngZaehler = 2
' Schleife über alle Zeilen
For lngZeile = 2 To IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, _
Rows.Count)
' Inhalte aus Spalte F und G summieren
dblPruefWert = dblPruefWert + Worksheets("Tabelle1").Cells(lngZeile, 6) + Worksheets(" _
Tabelle1").Cells(lngZeile, 7)
' laufende Zelle in Spalte B ist veschieden von nächster Zelle
If Worksheets("Tabelle1").Cells(lngZeile + 1, 2) Worksheets("Tabelle1").Cells(lngZeile, _
2) Then
' in Spalte F und G sind Werte > 0 enthalten
If dblPruefWert 0 Then
' Diagrammblatt erstellen
With Charts.Add
' ans Ende stellen
.Move after:=Sheets(Sheets.Count)
' Name aus Zelle
.Name = Worksheets("Tabelle1").Cells(lngZeile, 2).Value
' Diagrammtyp Linie mit Datenpunkten
.ChartType = xlLineMarkers
' Wertebereich zuweisen
.SetSourceData Source:=Worksheets("Tabelle1").Range("$F$" & lngZaehler & ":$G$" & _
lngZeile)
' X-Wertebereich zuweisen
.SeriesCollection(1).XValues = Worksheets("Tabelle1").Range("A" & lngZaehler & ": _
A" & lngZeile)
' Diagrammtitel zentriert über Diagramm
.SetElement (msoElementChartTitleAboveChart)
' Diagrammtitel aus Zelle
.ChartTitle.Text = Worksheets("Tabelle1").Cells(lngZeile, 2).Value
End With
' Prüfwert zurücksetzen
dblPruefWert = 0
End If
lngZaehler = lngZeile + 1
End If
Next lngZeile
' Bildschirmaktualisierung einschalten
Application.ScreenUpdating = True
End Sub