AW: VBA: xy-Diagramme erstellen und Daten zuweisen
10.03.2017 14:05:12
Beverly
Hi,
Sub Test()
Dim chrDia As ChartObject
Dim rngBereich1 As Range
Dim lngZeile As Long
Dim lngZaehler As Long
Dim lngDias As Long
Dim lngTop As Long
Dim intDia As Integer
Dim intLeft As Integer
Dim wksTab As Worksheet
Dim wksNeu As Worksheet
Set wksTab = Worksheets("Tabelle1")
lngZaehler = 2
lngTop = 3
intLeft = 1
Application.ScreenUpdating = False
Sheets.Add After:=Worksheets(Worksheets.Count)
Set wksNeu = Worksheets(Worksheets.Count)
For lngDias = 1 To 5
With wksTab
For intDia = 1 To 3
For lngZeile = lngZaehler To 21 Step 5
If rngBereich1 Is Nothing Then
Set rngBereich1 = .Range(.Cells(lngZeile, intDia + 1), .Cells(lngZeile, _
intDia + 1))
Else
Set rngBereich1 = Union(rngBereich1, .Range(.Cells(lngZeile, intDia + 1) _
, .Cells(lngZeile, intDia + 1)))
End If
Next lngZeile
With Worksheets(Worksheets.Count).Shapes.AddChart2(332, xlLineMarkers).Chart
.Parent.Left = wksNeu.Columns(intLeft).Left
.Parent.Top = ActiveSheet.Cells(lngTop, 1).Top
.Parent.Height = wksNeu.Range(wksNeu.Cells(lngTop, 1), wksNeu.Cells(lngTop + _
16, 1)).Height
With .SeriesCollection.NewSeries
.Name = wksTab.Cells(1, intDia + 1)
.Values = rngBereich1
End With
intLeft = intLeft + 6
End With
Set rngBereich1 = Nothing
Next intDia
End With
lngTop = lngTop + 17
intLeft = 1
lngZaehler = lngZaehler + 1
Next lngDias
For Each chrDia In wksNeu.ChartObjects
With chrDia.Chart
.Axes(xlValue).HasTitle = True
.Axes(xlCategory).HasTitle = True
With .Axes(xlValue).AxisTitle.Format.TextFrame2.TextRange.Characters(1, 3)
With .ParagraphFormat
.TextDirection = msoTextDirectionLeftToRight
.Alignment = msoAlignCenter
End With
With .Font
.BaselineOffset = 0
.Bold = msoFalse
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(89, 89, 89)
.Fill.Transparency = 0
.Fill.Solid
.Size = 10
.Italic = msoFalse
.Kerning = 12
.Name = "+mn-lt"
.UnderlineStyle = msoNoUnderline
.Strike = msoNoStrike
End With
End With
With .Axes(xlCategory).AxisTitle.Format.TextFrame2.TextRange.Characters(1, 4)
With .ParagraphFormat
.TextDirection = msoTextDirectionLeftToRight
.Alignment = msoAlignCenter
End With
With .Font
.BaselineOffset = 0
.Bold = msoFalse
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(89, 89, 89)
.Fill.Transparency = 0
.Fill.Solid
.Size = 10
.Italic = msoFalse
.Kerning = 12
.Name = "+mn-lt"
.UnderlineStyle = msoNoUnderline
.Strike = msoNoStrike
End With
End With
End With
Next chrDia
Application.ScreenUpdating = True
Set wksTab = Nothing
Set wksNeu = Nothing
End Sub