Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1652to1656
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA Code funktioniert nach Neustart nicht mehr

VBA Code funktioniert nach Neustart nicht mehr
25.10.2018 10:15:56
Harald.P.
Hallo wertes Forum,
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!

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Bitte Mappe hochladen - o.w.T.
25.10.2018 10:35:54
Beverly


Code funktioniert...
25.10.2018 15:11:03
Beverly
..bei mir problemlos, auch wenn ca. 1200 Diagrammblätter in der Mappe erzeugt wurden, da du die Codezeile zum Löschen des erstellten Diagrammblattes "sinniger Weise" auskommentiert hattest.
Außerdem wird immer dasselbe Diagramm erstellt, weil du den Bereich Probant zu Beginn mit der Codezeile
Set Probant = Sheets("Zugehörigkeit").Range("B8:D8")
fix festlegst - sollte der sich nicht den eigentlichen Werten (also Zeilen) anpassen? Es fragt sich auch, weshalb du das Diagramm jedesmal neu erstellst - es reicht doch, wenn du das Diagramm einmalig erstellst und dann nur den Wertebereich für die jeweilige Zeile (Probant) änderst.
Meine Lösung würde wie folgt aussehen:
Sub Graphik_erstellen()
' Graphik_erstellen Makro
' Programmschritte und Excel-Meldungen 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")
iRow = Sheets("Zugehörigkeit").Cells(Rows.Count, 1).End(xlUp).Row - 7
Set MyChart = Charts.Add
MyChart.SetSourceData Source:=DataRange
' Diagramm hinzufügen und Typ festlegen:
With MyChart
.HasTitle = True
.ChartTitle.Text = "Zugehörigkeitsgefühl"
.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 = ""
' Reihenname UT entfernen
.Legend.LegendEntries(2).Delete
With .FullSeriesCollection(3).Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With
' neue Datenreihe hinzufügen für probant-Daten
With .SeriesCollection.NewSeries
.ChartType = xlLine
With .Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent2
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Weight = 2.5
End With
' Schleife über alle Zeilen
For i = 8 To iRow
' Probantendaten festlegen und einfügen
Set Probant = Sheets("Zugehörigkeit").Range("B" & i & ":D" & i)
.Name = Sheets("Zugehörigkeit").Cells(i, 1)
.Values = Probant
' Diagramm_exportieren
.Parent.Parent.Export Filename:="C:\Users\DS\Desktop\Diagramme\" & _
Sheets("Zugehörigkeit").Cells(i, 1) & ".gif"
Next i
End With
.Delete
End With
' Programmschritte und Excel-Meldungen wieder anzeigen
Application.ScreenUpdating = False
Application.DisplayAlerts = False
End Sub

Anzeige
AW: Code funktioniert...
25.10.2018 15:46:59
Harald.P.
Danke für die Antwort und entschuldige bitte die 1200 Diagramme. Das war doof.
Du hast schon recht. Es muss nicht dauernd ein Neues Diagramm erzeugt werden. Deine Lösung ist da schon eleganter. Aber leider wird mir da auch nichts angezeigt. Sprich die Diagramme wurden nicht exportiert. Muss wohl an meinen Excel-Einstellungen liegen. Nur habe ich keine Ahnung, was es sein könnte. Hast Du eventuell eine Idee?
Dein Code exportiert die Diagramme...
25.10.2018 17:38:58
Beverly
...auf den Desktop - hast du schon mal versucht, sie stattdessen in ein Verzeichnis auf der Festplatte zu zu exportieren?


Anzeige
AW: Dein Code exportiert die Diagramme...
25.10.2018 17:56:07
Harald.P.
Ich habe es gerade mit deinem Code versucht. Und tatsächlich tut sich was. Allerdings ist es ein Runtime Error'9': "Subscript out of Range" für
Set DataRange = Sheets("Zugehörigkeit").Range("A1:D4")
Ich habe echt keine Ahnung, was VBA von mir will. Vorher hat es gar nicht reagiert und dann ändert man den Zielordner und es kommt diese Fehlermeldung.
AW: Dein Code exportiert die Diagramme...
25.10.2018 18:08:47
Beverly
Ist es diselbe Arbeitsmappe die du hochgeladen hast oder eine andere? Eventuell stört sich Excel2013 an der Variablen "DataRange"? Benenne sie doch einfach mal um.


Anzeige

308 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige