Diagramm mit Subtitel
23.06.2018 12:21:03
Norman
ich hab ein Makro geschrieben, das ein Diagramm erstellt.
Dieses würde ich nun gerne so ändern. Das das Diagramm einen Subtitel bekommt und der dem Dateinamen entspricht.
Ich hab erst versucht im Titel nen Zeilenumbruch zu machen und die beiden Zeilen getrennt zu formatieren, aber das will nicht recht gelingen.
Im Internet habe ich zu Subtitel hinzufügen folgenden Code gefunden:
Quelle:
https://stackoverflow.com/questions/31814454/adding-a-subtitle-to-a-chart-vba
Sub AddSubtitle(Ch As Chart, subtitle As String, Optional fontsize As Long = 12)
Dim NewTitle As String
Dim i As Long, n As Long
Dim CT As ChartTitle
Set CT = Ch.ChartTitle
NewTitle = CT.Text
NewTitle = NewTitle & Chr(13)
i = 1 + Len(NewTitle)
NewTitle = NewTitle & subtitle
n = Len(subtitle)
CT.Text = NewTitle
CT.Format.TextFrame2.TextRange.Characters(i, n).Font.Size = fontsize
End Sub
Sub test()
Dim myChart As Chart
Set myChart = ActiveSheet.ChartObjects(1).Chart
AddSubtitle myChart, "Subtitle", 10
End Sub
bekomme ich aber gerade irgendwie nicht in mein bestehendes Makro eingebaut.
Hier mal mein verkürztes Makro:
Sub Datei_import()
' ###### Varibalen initialisieren - START ######
' --- Variablen für Programmablauf ---
Dim zDatei As String ' Zieldatei
Dim zPfad As String ' Zielpfad mit Datei
Dim zPfadH As String ' Zielpfad ohne Datei
Dim zDateiH As String ' Zieldatei mit Pfad
Dim startzeile As Long
Dim endzeile As Long
Dim Spaltenzaehler As Integer
Dim i As Long
' --- Variablen für Charts ---
Dim co As ChartObject
Dim cht As Chart
Dim isCharttitel As ChartTitle
Dim subtitle As String
Dim sc1 As SeriesCollection
Dim ser1 As Series
' ###### Varibalen initialisieren - Ende ######
Application.ScreenUpdating = False
' ###### Dateien laden und verknüpfen - START ######
' #### Arbeitsdatei ####
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Title = "Datei wählen"
If .Show = -1 Then
zDateiH = .SelectedItems(1)
End If
End With
UserForm1.Show 0
UserForm1.Repaint
Set fso = CreateObject("Scripting.FileSystemObject")
oname = fso.getfilename(zPfadH)
' aktive Datei "Workbooks wird genau der Datei aus dem gebauten Pfad zugeordnet
Workbooks.Open zDateiH ' Zieldatei
zDatei = ActiveWorkbook.Name
' ###### Dateien laden und verknüpfen - START ######
' ###### Spalten und Zeilen zählen - START ######
Spaltenzaehler = Workbooks(zDatei).Sheets(1).Cells(1, Columns.Count).End(xlToLeft). _
Column
endzeile = Workbooks(zDatei).Sheets(11).Cells(Rows.Count, 1).End(xlUp).Row
' ###### Spalten und Zeilen zählen - ENDE ######
With Workbooks(zDatei).Sheets(11)
Set co = .ChartObjects.Add(.Range("A5").Left, .Range("A5").Top, 500, 300)
End With
co.Name = "F to s Graph"
Set cht = co.Chart
With Workbooks(zDatei)
With cht
.ChartType = xlXYScatterLinesNoMarkers
.ChartStyle = 241
.HasLegend = True
' ====== Beschriftung Diagramm ======
.HasTitle = True
.ChartTitle.Text = "Kraft-Weg-Diagramm von" & vbCrLf & zDatei
' Set isCharttitel = isCharttitel.ChartTitle
' NewTitle = isCharttitel.Text
' NewTitle = NewTitle & Chr(13)
' i = 1 + Len(NewTitle)
' NewTitle = NewTitle & subtitle
' n = Len(subtitle)
' isCharttitel.Text = NewTitle
' isCharttitel.Format.TextFrame2.TextRange.Characters(i, n).Font.Size = _
FontSize
' ====== Beschriftung Achsen - START ======
' --- X-Achse ---
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Weg in mm"
.Axes(xlCategory).TickLabelPosition = xlLow
' --> x-Achsenbeschriftung unter das Diagramm setzen
' --- Y-Achse ---
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Kraft in N"
' ====== Beschriftung Achsen - ENDE ======
' ====== Formatierung Achsen - START ======
' --- X-Achse ---
.PlotArea.Select
.Axes(xlCategory).TickLabels.NumberFormat = "#.##0"
' --- Y-Achse ---
.PlotArea.Select
.Axes(xlValue).TickLabels.NumberFormat = "#.##0"
' ====== Formatierung Achsen - ENDE ======
' ### Variante 2 - mit SeriesCollection - START ### (geht)
For i = 1 To Spaltenzaehler - 4
With .SeriesCollection.NewSeries
.Name = "M" & i
.XValues = Sheets(7).Range(Sheets(7).Cells(5, i), Sheets(7). _
Cells(endzeile, i))
.Values = Sheets(9).Range(Sheets(9).Cells(5, i), Sheets(9). _
Cells(endzeile, i))
With .Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(145, 145, 145)
.Weight = 0.5
.Transparency = 0
End With
End With
Next
' ### Variante 2 - mit SeriesCollection - ENDE ### ()
' ##### Graph erstellen - Start #####
End With
End With
Unload UserForm1
Application.ScreenUpdating = True
MsgBox "Datenimport und -aufbereitung fertig!"
End Sub