Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.
Clever-Excel-Forum › Office-Anwendungen › Excel v
Diagramme kopieren

Thema geschlossen 
Baumstrukturmodus
Diagramme kopieren
Phi.VBA Offline
Benutzer
Registriert seit: 17.11.2017
Version(en): 2016
#21
21.12.2017, 12:47 (Dieser Beitrag wurde zuletzt bearbeitet: 21.12.2017, 12:47 von Phi.VBA.)
gelöscht
Suchen
Antworten Top
Fennek Offline
Benutzer
Registriert seit: 06.12.2015
Version(en): 2016
#22
21.12.2017, 13:40
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:
  • rob70
Suchen
Antworten Top
rob70 Offline
CEF Einsteiger
ThreadStarter
*
Registriert seit: 18.12.2017
Version(en): 2010
#23
21.12.2017, 16:37
(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
Suchen
Antworten Top
Fennek Offline
Benutzer
Registriert seit: 06.12.2015
Version(en): 2016
#24
21.12.2017, 16:55
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:
  • rob70
Suchen
Antworten Top
rob70 Offline
CEF Einsteiger
ThreadStarter
*
Registriert seit: 18.12.2017
Version(en): 2010
#25
21.12.2017, 17:54
(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
...
Suchen
Antworten Top
rob70 Offline
CEF Einsteiger
ThreadStarter
*
Registriert seit: 18.12.2017
Version(en): 2010
#26
21.12.2017, 19:23
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
Suchen
Antworten Top
Thema geschlossen 


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste