Diagramme kopieren

[Phi.VBA]

gelöscht

[Fennek]

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

[rob70]

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

[Fennek]

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

[rob70]

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
...

[rob70]

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