VBA Code funktioniert nach Neustart nicht mehr
25.10.2018 10:15:56
Harald.P.
Ich habe ein Makro zum Erstellen und Exportieren von Diagrammen geschrieben. Der Code hat gestern auch super funktioniert und ist ohne Probleme durchgelaufen. Leider läuft heute gar nichts mehr. Ich habe nur die Farbe einer Datenreihe geändert. Wenn ich nun das Makro laufen lasse, passiert nichts. Kein Output, keine Fehlermeldung. Ein anderes kleines Makro zum Zählen der Datensätze läuft aber ohne Probleme. Ich stehe gerade ordentlich auf dem Schlauch und weiß einfach nicht, was das Problem ist. Kann mir hier bitte jemand weiterhelfen?
Um Folgenden Code handelt es sich:
Sub Graphik_erstellen()
' Graphik_erstellen Makro
' Programmschritte und Fragen nicht anzeigen
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Variablen bestimmen
Dim MyChart As Chart
Dim DataRange As Range
Dim OT As Range
Dim MW As Range
Dim UT As Range
Dim Probant As Range
Dim i As Integer
Dim iRow As Long
' Eigenschaften und Werte zuweisen
Set DataRange = Sheets("Zugehörigkeit").Range("A1:D4")
Set OT = Sheets("Zugehörigkeit").Range("B2:D2")
Set MW = Sheets("Zugehörigkeit").Range("B3:D3")
Set UT = Sheets("Zugehörigkeit").Range("B4:D4")
Set Probant = Sheets("Zugehörigkeit").Range("B8:D8")
iRow = Sheets("Zugehörigkeit").Cells(Rows.Count, 1).End(xlUp).Row - 7
' Start Iterationsschleife
For i = 8 To iRow
' Diagramm hinzufügen und Typ festlegen:
Set MyChart = Charts.Add
MyChart.SetSourceData Source:=DataRange
With ActiveChart
.HasTitle = True
.ChartTitle.Text = "Zugehörigkeit"
.HasLegend = True
.Legend.Position = xlLegendPositionBottom
.SetElement msoElementPrimaryValueGridLinesNone
.ChartType = xlColumnClustered
' Axen ausrichten und benennen:
.Axes(xlValue).MinimumScale = 0
.Axes(xlValue).MaximumScale = 6
' Oberen Bereich des Durchschnittskorridors festlegen
.FullSeriesCollection(1).ChartType = xlArea
.FullSeriesCollection(1).Values = OT
.FullSeriesCollection(1).Name = "Durchschnittsbereich"
With .FullSeriesCollection(1).Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground2
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With
' Mittelwert festlegen
.FullSeriesCollection(2).ChartType = xlLine
.FullSeriesCollection(2).Values = MW
.FullSeriesCollection(2).Name = "Mittelwert"
With .FullSeriesCollection(2).Format.Line
.Visible = msoTrue
.Weight = 2.5
.ForeColor.ObjectThemeColor = msoThemeColorBackground2
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = -0.25
.Transparency = 0
End With
' Unteren Bereich des Durchschnittskorridors festlegen
.FullSeriesCollection(3).ChartType = xlArea
.FullSeriesCollection(3).Values = UT
.FullSeriesCollection(3).Name = ""
With .FullSeriesCollection(3).Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With
End With
' Probantendaten einfügen
ActiveChart.SeriesCollection.NewSeries
ActiveChart.FullSeriesCollection(4).Name = Sheets("Zugehörigkeit").Cells(i, 1)
ActiveChart.FullSeriesCollection(4).ChartType = xlLine
ActiveChart.FullSeriesCollection(4).Values = Probant
With ActiveChart.FullSeriesCollection(4).Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent2
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Weight = 2.5
End With
' Reihenname UT entfernen
ActiveChart.Legend.LegendEntries(2).Select
Selection.Delete
' Diagramm_exportieren
ActiveChart.Export Filename:="C:\Users\DS\Desktop\Diagramme\" & Sheets("Zugehörigkeit"). _
Cells(i, 1) & ".gif"
'Diagramm löschen
ActiveChart.Delete
Next i
End Sub
Sub Probanten_zählen()
Dim iRows As Integer
Dim Msg As String
iRows = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row - 7
Msg = iRows
MsgBox (Msg)
End Sub
Schon mal vielen Dank für Eure Hilfe!