Registriert seit: 17.11.2017
Version(en): 2016
21.12.2017, 12:47
(Dieser Beitrag wurde zuletzt bearbeitet: 21.12.2017, 12:47 von Phi.VBA.)
gelöscht
Registriert seit: 06.12.2015
Version(en): 2016
Hallo,
dieser halb-manuelle Code läuft unter xl2016. Der Cursor wird auf den Titel in Spalte A gestellt und dann am besten mit einem short-cut gestartet.
Code: Public r As Integer
Sub Rolf_Daten()
'strg-d
'Cursor auf Titel in Spalte A ##########################
'ActiveCell auf Titel, z.B. A3
Dim WS As Worksheet: Set WS = ActiveSheet
'Range("A16").Select ' <<<<<<<<<<< setzt >>>>>>>>>>>
r = ActiveCell.Row
Set Col = Range(Cells(r, 4), Cells(r, "R")).SpecialCells(xlCellTypeConstants).EntireColumn
'Chart-Daten
Range(Cells(r, "AA"), Cells(r, "AH")).NumberFormat = "@"
Range(Cells(r, 4), Cells(r, "R")).SpecialCells(xlCellTypeConstants).Copy Cells(r, "AA")
Intersect(Rows(r + 1), Col).Copy Cells(r + 1, "AA")
Cells(r + 1, "Z") = "Center"
Intersect(Rows(r + 1), Col.Offset(, 1)).Copy Cells(r + 2, "AA")
Cells(r + 2, "Z") = "Center_MfT"
Intersect(Rows(r + 6), Col).Copy Cells(r + 3, "AA")
Cells(r + 3, "Z") = "Thirds"
Intersect(Rows(r + 6), Col.Offset(, 1)).Copy Cells(r + 4, "AA")
Cells(r + 4, "Z") = "Thirds_MfT"
Intersect(Rows(r + 11), Col).Copy Cells(r + 5, "AA")
Cells(r + 5, "Z") = "Corner"
Intersect(Rows(r + 11), Col.Offset(, 1)).Copy Cells(r + 6, "AA")
Cells(r + 6, "Z") = "Corner_MfT"
Cells(r, "Z").CurrentRegion.Select
ActiveSheet.Shapes.AddChart2(227, xlLine).Select
Make_Chart
End Sub
'############# Chart ###################
'strg-f
Sub Make_Chart()
Dim ChtObj As ChartObject
Dim Cht As Chart
Set ChtObj = ActiveSheet.ChartObjects(ActiveSheet.ChartObjects.Count)
ChtObj.Activate
With ChtObj
.Top = Cells(r + 1, "T").Top
.Left = Cells(r, "T").Left
.ShapeRange.ScaleHeight 0.7894491834, msoFalse, msoScaleFromTopLeft
End With
With ActiveChart
.ChartTitle.Text = Cells(r, 1)
.Legend.Select
Selection.Position = xlRight
Selection.Format.Line.Visible = msoFalse
.Axes(xlValue).Select
.Axes(xlValue).MinimumScale = 0
.Axes(xlValue).MaximumScale = 2500
.Axes(xlValue).MajorUnit = 500
.Axes(xlValue).MinimumScale = 200
.Axes(xlValue).MaximumScale = 2200
.Axes(xlValue).MajorUnit = 200
.Axes(xlCategory).Select
.ChartArea.Select
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
End With
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(146, 208, 80)
.Transparency = 0
End With
ActiveChart.SeriesCollection(5).Select
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(146, 208, 80)
End With
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(253, 99, 99)
.Transparency = 0
End With
ActiveChart.SeriesCollection(6).Select
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(253, 99, 99)
End With
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(146, 208, 80)
.Transparency = 0
End With
ActiveChart.SeriesCollection(4).Select
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText2
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0.6000000238
.Transparency = 0
End With
With Selection.Format.Line
.Visible = msoTrue
.Weight = 2
End With
With Selection.Format.Line
.Visible = msoTrue
.DashStyle = msoLineSysDash
End With
ActiveChart.SeriesCollection(5).Select
With Selection.Format.Line
.Visible = msoTrue
.Weight = 1.75
End With
With Selection.Format.Line
.Visible = msoTrue
.DashStyle = msoLineSysDash
End With
ActiveChart.SeriesCollection(6).Select
With Selection.Format.Line
.Visible = msoTrue
.Weight = 1.75
End With
With Selection.Format.Line
.Visible = msoTrue
.DashStyle = msoLineSysDash
End With
ActiveChart.SeriesCollection(1).Select
With Selection.Format.Line
.Visible = msoTrue
.Weight = 1.75
End With
ActiveChart.SeriesCollection(2).Select
With Selection.Format.Line
.Visible = msoTrue
.Weight = 1.75
End With
ActiveChart.SeriesCollection(3).Select
With Selection.Format.Line
.Visible = msoTrue
.Weight = 1.75
End With
End With
End Sub
Die Formatierung ist aus deinem aufgezeichneten Code (modifiziert) übernommen.
mfg
Folgende(r) 1 Nutzer sagt Danke an Fennek für diesen Beitrag:1 Nutzer sagt Danke an Fennek für diesen Beitrag 28
• rob70
Registriert seit: 18.12.2017
Version(en): 2010
(21.12.2017, 13:40)Fennek schrieb: Hallo,
dieser halb-manuelle Code läuft unter xl2016. Der Cursor wird auf den Titel in Spalte A gestellt und dann am besten mit einem short-cut gestartet.
Die Formatierung ist aus deinem aufgezeichneten Code (modifiziert) übernommen.
mfg
Hallo,
zum gefühlt "hundertsten" mal: VIELEN DANK. Leider:
ich hab's gerade probiert. Der Code hängt sich immer noch auf. Diesmal zeigt der Debugger auf die Zeile "ActiveSheet.Shapes.AddChart2(227, xlLine).Select", vermutlich kennt XL2010 die Methode AddChart2 nicht.
Die Tastaturshortcut's sind schon eingestellt wie zu Beginn des Codes angezeigt? Strg+d klappte nicht. Wo stellt man die shortcuts eigentlich ein, wenn man NICHT ein neues Makro über den Rekorder aufnimmt (dann wüsste ich's).
VG, Rolf
Registriert seit: 06.12.2015
Version(en): 2016
Hallo Rolf,
etwas findiger wäre ganz gut.
Also kopiere die Daten aus Tabelle1 in ein neuer Sheet und führe diesen Code aus:
Code: Public r As Integer
Sub Rolf_Daten()
'strg-d
'Cursor auf Titel in Spalte A ##########################
'ActiveCell auf Titel, z.B. A3
Dim WS As Worksheet: Set WS = ActiveSheet
'Range("A16").Select ' <<<<<<<<<<< setzt >>>>>>>>>>>
r = ActiveCell.Row
Set Col = Range(Cells(r, 4), Cells(r, "R")).SpecialCells(xlCellTypeConstants).EntireColumn
'Chart-Daten
Range(Cells(r, "AA"), Cells(r, "AH")).NumberFormat = "@"
Range(Cells(r, 4), Cells(r, "R")).SpecialCells(xlCellTypeConstants).Copy Cells(r, "AA")
Intersect(Rows(r + 1), Col).Copy Cells(r + 1, "AA")
Cells(r + 1, "Z") = "Center"
Intersect(Rows(r + 1), Col.Offset(, 1)).Copy Cells(r + 2, "AA")
Cells(r + 2, "Z") = "Center_MfT"
Intersect(Rows(r + 6), Col).Copy Cells(r + 3, "AA")
Cells(r + 3, "Z") = "Thirds"
Intersect(Rows(r + 6), Col.Offset(, 1)).Copy Cells(r + 4, "AA")
Cells(r + 4, "Z") = "Thirds_MfT"
Intersect(Rows(r + 11), Col).Copy Cells(r + 5, "AA")
Cells(r + 5, "Z") = "Corner"
Intersect(Rows(r + 11), Col.Offset(, 1)).Copy Cells(r + 6, "AA")
Cells(r + 6, "Z") = "Corner_MfT"
Cells(r, "Z").CurrentRegion.Select
end sub
Die neue Tabelle ab Spalte Z muss noch markiert sein. Starte den Makro-Rekorder und füge einen Linien-Chart ein. Stoppe den Rekorder und übertrage den Code für das Erstellen des Chart in meinen Makro.
Falls weiter Fehlmeldungen kommen, mache das genauso.
mfg
Folgende(r) 1 Nutzer sagt Danke an Fennek für diesen Beitrag:1 Nutzer sagt Danke an Fennek für diesen Beitrag 28
• rob70
Registriert seit: 18.12.2017
Version(en): 2010
(21.12.2017, 16:55)Fennek schrieb: Hallo Rolf,
etwas findiger wäre ganz gut.
Sorry, ich bin eben kein Programmierer und habe auch noch nie programmiert, auch wenn die Logik hinter dem Code weitgehend lesbar ist, habe ich jede Zeile eine neue Frage. Nun, mit deinem Hinweis habe ich jetzt zumindest ein Chart hinzufügen können.
Das nächste Problem, das ich nicht lösen konnte ist: Das Chart enthält viel zu viele Kurven und keine Legende, daher kann das Makro auch nicht darauf zugreifen.
So sieht es aus:
Da ich aber leider nicht kapiere, wie genau XL die Daten übergeben werden, kann ich das auch nicht ändern. Wie funktioniert das mit den Special Cells?
Soweit bin ich jetzt gekommen (ich weiß nur minimal weiter):
Code: Sub Rolf_Daten()
'strg-d
'Cursor auf Titel in Spalte A ##########################
'ActiveCell auf Titel, z.B. A3
Dim WS As Worksheet: Set WS = ActiveSheet
'Range("A16").Select ' <<<<<<<<<<< setzt >>>>>>>>>>>
r = ActiveCell.Row
Set Col = Range(Cells(r, 4), Cells(r, "R")).SpecialCells(xlCellTypeConstants).EntireColumn
'Chart-Daten
Range(Cells(r, "AA"), Cells(r, "AH")).NumberFormat = "@"
Range(Cells(r, 4), Cells(r, "R")).SpecialCells(xlCellTypeConstants).Copy Cells(r, "AA")
Intersect(Rows(r + 1), Col).Copy Cells(r + 1, "AA")
Cells(r + 1, "Z") = "Center"
Intersect(Rows(r + 1), Col.Offset(, 1)).Copy Cells(r + 2, "AA")
Cells(r + 2, "Z") = "Center_MfT"
Intersect(Rows(r + 6), Col).Copy Cells(r + 3, "AA")
Cells(r + 3, "Z") = "Thirds"
Intersect(Rows(r + 6), Col.Offset(, 1)).Copy Cells(r + 4, "AA")
Cells(r + 4, "Z") = "Thirds_MfT"
Intersect(Rows(r + 11), Col).Copy Cells(r + 5, "AA")
Cells(r + 5, "Z") = "Corner"
Intersect(Rows(r + 11), Col.Offset(, 1)).Copy Cells(r + 6, "AA")
Cells(r + 6, "Z") = "Corner_MfT"
Cells(r, "Z").CurrentRegion.Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlLine
Make_Chart
End Sub
'############# Chart ###################
'strg-f
Sub Make_Chart()
Dim ChtObj As ChartObject
Dim Cht As Chart
Set ChtObj = ActiveSheet.ChartObjects(ActiveSheet.ChartObjects.Count)
ChtObj.Activate
With ChtObj
.Top = Cells(r + 1, "T").Top
.Left = Cells(r, "T").Left
.ShapeRange.ScaleHeight 0.7894491834, msoFalse, msoScaleFromTopLeft
End With
With ActiveChart
.SetElement (msoElementChartTitleAboveChart)
.ChartTitle.Text = Cells(r, 1)
.Legend.Select
...
Registriert seit: 18.12.2017
Version(en): 2010
Nur zur Info:
Ich bin jetzt selbst zum Ziel gekommen. Es hat sich herausgestellt, dass das Makro, was ich ursprünglich aufgenommen hatte, um eine Grundlage für weiteren Code an Euch zu geben, leichter verständlich war, so dass ich es so anpassen konnte, dass es jetzt funktioniert.
Mit folgendem Code bin ich nun am Ziel (sicher weit weniger elegant als gut geschriebener Code):
Code: Sub Make_Chart()
'
' Make_Chart Makro
'
'
r = ActiveCell.Row
s = ActiveCell.Column
ActiveCell.Offset(1, 1).Range("A1:I1").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlLine
ActiveChart.SetElement (msoElementChartTitleAboveChart)
ActiveChart.ChartTitle.Text = Cells(r, s)
ActiveChart.SetElement (msoElementLegendRight)
ActiveChart.SetSourceData Source:=Range(Cells(r + 1, s + 2), Cells(r + 1, s + 9))
ActiveChart.Axes(xlValue).Select
ActiveChart.Axes(xlValue).MinimumScale = 0
ActiveChart.Axes(xlValue).MaximumScale = 2500
ActiveChart.Axes(xlValue).MajorUnit = 500
ActiveChart.Axes(xlValue).MinimumScale = 200
ActiveChart.Axes(xlValue).MaximumScale = 2200
ActiveChart.Axes(xlValue).MajorUnit = 200
ActiveChart.Axes(xlCategory).Select
ActiveChart.ChartArea.Select
ActiveChart.SeriesCollection(1).XValues = Range(Cells(r, s + 1), Cells(r, s + 9))
ActiveChart.SeriesCollection(1).Name = Cells(r + 1, s).Value
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(2).Name = Cells(r + 6, s).Value
ActiveChart.SeriesCollection(2).Values = Range(Cells(r + 6, s + 2), Cells(r + 6, s + 9))
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(3).Name = Cells(r + 11, s).Value
ActiveChart.SeriesCollection(3).Values = Range(Cells(r + 11, s + 2), Cells(r + 11, s + 9))
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(4).Name = Cells(r + 1, s + 11).Value
ActiveChart.SeriesCollection(4).Values = Range(Cells(r + 1, s + 12), Cells(r + 1, s + 20))
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(5).Name = Cells(r + 6, s + 11).Value
ActiveChart.SeriesCollection(5).Values = Range(Cells(r + 6, s + 12), Cells(r + 6, s + 20))
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(6).Name = Cells(r + 11, s + 11).Value
ActiveChart.SeriesCollection(6).Values = Range(Cells(r + 11, s + 12), Cells(r + 11, s + 20))
ActiveChart.SeriesCollection(2).XValues = Range(Cells(r, s + 1), Cells(r, s + 9))
ActiveChart.SeriesCollection(4).Select
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
End With
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(146, 208, 80)
.Transparency = 0
End With
ActiveChart.SeriesCollection(5).Select
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(146, 208, 80)
End With
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(253, 99, 99)
.Transparency = 0
End With
ActiveChart.SeriesCollection(6).Select
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(253, 99, 99)
End With
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(146, 208, 80)
.Transparency = 0
End With
ActiveChart.SeriesCollection(4).Select
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText2
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0.6000000238
.Transparency = 0
End With
With Selection.Format.Line
.Visible = msoTrue
.Weight = 2
End With
With Selection.Format.Line
.Visible = msoTrue
.DashStyle = msoLineSysDash
End With
ActiveChart.SeriesCollection(5).Select
With Selection.Format.Line
.Visible = msoTrue
.Weight = 1.75
End With
With Selection.Format.Line
.Visible = msoTrue
.DashStyle = msoLineSysDash
End With
ActiveChart.SeriesCollection(6).Select
With Selection.Format.Line
.Visible = msoTrue
.Weight = 1.75
End With
With Selection.Format.Line
.Visible = msoTrue
.DashStyle = msoLineSysDash
End With
ActiveChart.SeriesCollection(1).Select
With Selection.Format.Line
.Visible = msoTrue
.Weight = 1.75
End With
ActiveChart.SeriesCollection(2).Select
With Selection.Format.Line
.Visible = msoTrue
.Weight = 1.75
End With
ActiveChart.SeriesCollection(3).Select
With Selection.Format.Line
.Visible = msoTrue
.Weight = 1.75
ActiveSheet.Shapes(ActiveSheet.ChartObjects.Count).ScaleHeight 0.8, msoFalse, _
msoScaleFromTopLeft
ActiveSheet.Shapes(ActiveSheet.ChartObjects.Count).ScaleWidth 1.25, msoFalse, _
msoScaleFromTopLeft
ActiveSheet.ChartObjects(ActiveSheet.ChartObjects.Count).Activate
ActiveChart.Parent.Cut
ActiveSheet.Cells(r, s + 23).Select
ActiveSheet.Paste
End With
End Sub
Nochmals Danke für die Hilfe, bzw. die Anregung zur Selbsthilfe.
VG, Rolf
|