AW: Laufzeitfehler
24.05.2005 18:12:07
Axel
Hallo Horst,
hier der komplette Code. Im Prinzip will ich dieses Sheets("Zug") überall ersetzen durch ActiveSheet oder etwas analoges, was mir ermöglicht, mein Makro auf beliebige Arbeitsblätter anzuwenden.
Vielen Dank,
Axel
Sub Abfrage()
If MsgBox("Diagrammerstellung?", vbQuestion + vbYesNo, "Hallo!") = vbNo Then
MsgBox " Ende...", vbExclamation
End 'Programm wird beendet
Else
Call Diagrammerstellung
End If
End Sub
Sub Diagrammerstellung()
' Diagrammerstellung Makro
' Makro am 24.04.2005 von aufgezeichnet
' Tastenkombination: Strg+a
Dim Geschwvektor As Range
Dim Spaltenauswahl As Range
Dim sim As Range
Dim Vergleich As Range
Dim Reihe As Range
Set Geschwvektor = Application.InputBox( _
prompt:="Auswahl des Geschwindigkeitsvektors.", _
Title:="Auswahl des Geschwindigkeitsvektors", Type:=8)
Set Spaltenauswahl = Application.InputBox( _
prompt:="Für Anzahl der Diagramme bitte entsprechende Anzahl Zellen auswählen.", _
Title:="Auswahl der Spalten", Type:=8)
Set sim = Application.InputBox( _
prompt:="Auswahl Zelle Start Werte", _
Title:="Auswahl der Zelle", Type:=8)
Set Vergleich = Application.InputBox( _
prompt:="Auswahl Zelle Start Vergleich", _
Title:="Auswahl der Zelle", Type:=8)
Dim zell As Object
Dim b As Integer
b = 0
For Each zell In Spaltenauswahl
b = b + 1
Next zell
Dim zell2 As Object
Dim a As Integer
a = 0
For Each zell2 In Geschwvektor
a = a + 1
Next zell2
For n = 2 To b
Charts.Add
ActiveChart.ChartType = xlXYScatterLines
' Auswahl Spalten 2 bis n
ActiveChart.SetSourceData Source:=Sheets("Zug").Range(Sheets("Zug").cells(1, n), _
Sheets("Zug").cells(a, n)), PlotBy:=xlColumns
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(1).XValues = Geschwvektor 'das bleibt immer gleich
ActiveChart.SeriesCollection(2).XValues = Geschwvektor 'das bleibt immer gleich
Reihe = Range(ActiveSheet.cells(sim.Row, n), ActiveSheet.cells(sim.Row + a, n))
ActiveChart.SeriesCollection(2).Values = Reihe
'ActiveChart.SeriesCollection(3).XValues = "=Zug!R18C1:R30C1" 'das bleibt immer gleich
ActiveChart.SeriesCollection(3).XValues = Geschwvektor
'Reihe = "=Zug!R34C" & n & ":R46C" & n
Reihe = Range(Sheets("Zug").cells(Vergleich.Row, n), Sheets("Zug").cells(Vergleich.Row + a, n))
ActiveChart.SeriesCollection(3).Values = Reihe
ActiveChart.Location Where:=xlLocationAsObject, Name:="Zug"
With ActiveChart
.HasTitle = False
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = _
"Geschwindigkeit [km/h]"
.Axes(xlValue, xlPrimary).HasTitle = False
End With
With ActiveChart
.HasAxis(xlCategory, xlPrimary) = True
.HasAxis(xlValue, xlPrimary) = True
End With
ActiveChart.Axes(xlCategory, xlPrimary).CategoryType = xlAutomatic
ActiveChart.SeriesCollection(3).Select
ActiveChart.SeriesCollection(3).AxisGroup = 2
ActiveChart.Legend.Select
ActiveChart.Axes(xlValue, xlSecondary).Select
Selection.TickLabels.NumberFormat = "0.000E+00"
With ActiveChart.Axes(xlValue, xlSecondary)
.MinimumScaleIsAuto = True
.MaximumScaleIsAuto = True
.MinorUnitIsAuto = True
'.MajorUnit = 0.000001 'Skalierung automatisiert
.Crosses = xlAutomatic
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
End With
ActiveChart.Axes(xlValue).MajorGridlines.Select
ActiveChart.Axes(xlValue).MajorGridlines.Select
ActiveChart.Axes(xlValue).Select
ActiveChart.PlotArea.Select
ActiveChart.Axes(xlValue).MajorGridlines.Select
Selection.Delete
ActiveChart.Legend.Select
ActiveChart.Legend.LegendEntries(1).LegendKey.Select
With Selection.Border
.Weight = xlThin
.LineStyle = xlNone
End With
With Selection
.MarkerBackgroundColorIndex = xlAutomatic
.MarkerForegroundColorIndex = xlAutomatic
.MarkerStyle = xlAutomatic
.Smooth = False
.MarkerSize = 5
.Shadow = False
End With
ActiveChart.Legend.LegendEntries(2).LegendKey.Select
With Selection.Border
.Weight = xlThin
.LineStyle = xlAutomatic
End With
With Selection
.MarkerBackgroundColorIndex = xlAutomatic
.MarkerForegroundColorIndex = xlAutomatic
.MarkerStyle = xlNone
.Smooth = False
.MarkerSize = 5
.Shadow = False
End With
Next
MsgBox "Durchlauf beendet"
Exit Sub
End Sub