Liniendiagramm anzeigen

Sub LinienDiagramm()
Dim strDName As String
Dim strBereich As String
Dim strTemp As String
Dim strGrafik As String
Dim objBlatt As Object
Dim bolVorhanden As Boolean
Dim lngLZ As Long, lngZ As Long
bolVorhanden = False
For Each objBlatt In ActiveWorkbook.Sheets
If objBlatt.Name = "Berechnung Versorgungslücke" Then
bolVorhanden = True
Exit For
End If
Next
If bolVorhanden = False Then
MsgBox "Das Blatt 'Berechnung Versorgungslücke' existiert nicht, das Diagramm kann nicht  _
erstellt werden.", vbOKOnly + vbExclamation, "Blatt fehlt"
Exit Sub
End If
On Error GoTo FEHLER
Application.ScreenUpdating = False
Set objBlatt = Sheets("Berechnung Versorgungslücke")
objBlatt.Visible = xlSheetVisible
Workbooks.Add
objBlatt.Range("A50:D119").Copy
ActiveSheet.Range("A50").PasteSpecial Paste:=xlValues
Range("A50:C119").NumberFormat = "$#,##0_);[Red]($#,##0)"
Range("D50:D119").NumberFormat = "YYYY"
For lngZ = 51 To 119
If Cells(lngZ, 1).Text  "" Then
If IsNumeric(Cells(lngZ, 1)) Then
lngLZ = lngZ
Else
Exit For
End If
End If
Next
strBereich = "A50:D" & lngLZ
strTemp = ActiveSheet.Name
Range("D50:D" & lngLZ).Copy
Range("A50").Insert Shift:=xlToRight
Range("E50:E" & lngLZ).ClearContents
'--------------------------------------------- Diagramm ---------------------------------------- _
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=strTemp
ActiveChart.SetSourceData Source:=Range(strBereich), PlotBy:=xlColumns
With ActiveChart
.ChartType = xlLine
.HasTitle = True
.ChartTitle.Characters.Text = "Situation im Alter"
.Axes(xlCategory, xlPrimary).HasTitle = False
'.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Jahr"
.Axes(xlValue, xlPrimary).HasTitle = False
'.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Betrag"
'.ApplyDataLabels Type:=xlDataLabelsShowValue, LegendKey:=False
.ApplyDataLabels Type:=xlDataLabelsShowNone, LegendKey:=False
.HasDataTable = False
.ChartArea.Border.Weight = 2
.ChartArea.Border.LineStyle = -1
.ChartArea.Interior.ColorIndex = 15
.ChartArea.Interior.PatternColorIndex = 1
.ChartArea.Interior.Pattern = 1
.PlotArea.Border.ColorIndex = 16
.PlotArea.Border.Weight = xlThin
.PlotArea.Border.LineStyle = xlContinuous
'Hier den Pfad zur Datei anpassen:
'Pfad zur Grafik zusammenbasteln:
'Pfad dieser Mappe:
'strGrafik = ThisWorkbook.Path
'If Right(strGrafik, 1)  "\" Then strGrafik = strGrafik & "\"
'Grafik:
strGrafik = "c:\situation im alter.bmp"
If Dir(strGrafik)  "" Then
.PlotArea.Fill.UserPicture PictureFile:=strGrafik
Else
.PlotArea.Interior.ColorIndex = 19
.PlotArea.Interior.PatternColorIndex = 1
.PlotArea.Interior.Pattern = xlSolid
End If
.SeriesCollection(3).Border.ColorIndex = 3
.SeriesCollection(3).Border.Weight = xlThick
.SeriesCollection(3).Border.LineStyle = xlContinuous
.SeriesCollection(2).Border.ColorIndex = 50
.SeriesCollection(2).Border.Weight = xlThick
.SeriesCollection(2).Border.LineStyle = xlContinuous
.SeriesCollection(1).Border.ColorIndex = 5
.SeriesCollection(1).Border.Weight = xlThick
.SeriesCollection(1).Border.LineStyle = xlContinuous
.Axes(xlValue).TickLabels.Font.Name = "Arial"
.Axes(xlValue).TickLabels.Font.FontStyle = "Fett Kursiv"
.Axes(xlValue).TickLabels.Font.Size = 10
.Axes(xlValue).TickLabels.AutoScaleFont = False
.Axes(xlCategory).TickLabels.Font.Name = "Arial"
.Axes(xlCategory).TickLabels.Font.FontStyle = "Fett Kursiv"
.Axes(xlCategory).TickLabels.Font.Size = 10
.Axes(xlCategory).TickLabels.AutoScaleFont = False
.Axes(xlCategory).TickLabels.Alignment = xlCenter
.Axes(xlCategory).TickLabels.Offset = 100
.Axes(xlCategory).TickLabels.Orientation = 45
.Axes(xlCategory).TickLabels.NumberFormat = "yyyy"
.Legend.Font.Name = "Arial"
.Legend.Font.FontStyle = "Fett Kursiv"
.Legend.Font.Size = 14
ActiveChart.PlotArea.Select
With Selection.Border
.ColorIndex = 16
.Weight = xlThin
.LineStyle = xlContinuous
End With
Selection.Fill.PresetGradient Style:=msoGradientHorizontal, Variant:=1, _
PresetGradientType:=msoGradientDaybreak
Selection.Fill.Visible = True
ActiveChart.ChartArea.Select
With Selection.Border
.Weight = 1
.LineStyle = -1
End With
Sheets("Tabelle1").DrawingObjects("Diagramm 1").RoundedCorners = False
Sheets("Tabelle1").DrawingObjects("Diagramm 1").Shadow = False
Selection.Fill.PresetGradient Style:=msoGradientHorizontal, Variant:=1, _
PresetGradientType:=msoGradientDaybreak
Selection.Fill.Visible = True
ActiveChart.Legend.Select
With Selection.Border
.Weight = xlHairline
.LineStyle = xlNone
End With
Selection.Shadow = False
Selection.Fill.PresetGradient Style:=msoGradientHorizontal, Variant:=1, _
PresetGradientType:=msoGradientDaybreak
Selection.Fill.Visible = True
Selection.Position = xlBottom
.ChartTitle.Shadow = True
.ChartTitle.AutoScaleFont = False
.ChartTitle.Border.ColorIndex = 57
.ChartTitle.Border.Weight = xlThin
.ChartTitle.Border.LineStyle = xlContinuous
.ChartTitle.Fill.PresetGradient Style:=msoGradientHorizontal, Variant:=1, _
PresetGradientType:=msoGradientDaybreak
.ChartTitle.Fill.Visible = True
.ChartTitle.Fill.ForeColor.SchemeColor = 5
.ChartTitle.Fill.BackColor.SchemeColor = 11
.ChartTitle.Font.Name = "Arial"
.ChartTitle.Font.FontStyle = "Fett"
.ChartTitle.Font.Size = 14
.ChartTitle.Font.ColorIndex = xlAutomatic
.Parent.Width = Image23.Width
.Parent.Height = Image23.Height
strTemp = ThisWorkbook.Path & Application.PathSeparator & "diagramm.gif"
.Export Filename:=strTemp, FilterName:="GIF"
Image23.Picture = LoadPicture(strTemp)
End With
FEHLER:
ActiveWorkbook.Close False
Application.ScreenUpdating = True
Set objBlatt = Nothing
End Sub