Excel Makro Sekundärachse als Liniendiagramm

  • #1
F

falcon30

Bekanntes Mitglied
Themenersteller
Dabei seit
21.06.2005
Beiträge
94
Reaktionspunkte
0
Hallo Zusammen,

ich habe eine Tabelle mit der per Makro ein Diagramm erzeugt wird.

Makro:

Code: 
Function LinienChartErstellen(wb As Workbook, ws As Worksheet, r As Range, _
               l_Start_zeile, l_Stop_zeile, _
               l_zeile As Long, _
               l_linkeSpalte As Long, _
               l_HoeheInZeilen As Long, _
               l_BreiteInSpalten As Long, _
               s_AddTextUberschrift As String)
  
  Dim ch As Chart, cho As ChartObject
 ->Dim l_z As Long, l_z_end As Long, l_c As Long, x As Long, s_tmp As String
  
 ->Chart erzeugen
  Set ch = wb.Charts.Add
  With ch
   .ChartType = xlColumnStacked
   .SetSourceData Source:=r, PlotBy:=xlColumns
   .HasTitle = True
   .ChartTitle.Text = s_AddTextUberschrift
   .ChartTitle.AutoScaleFont = False
   .ChartTitle.Font.Size = 12
   .Axes(xlCategory, xlPrimary).HasTitle = False
   .Axes(xlValue, xlPrimary).HasTitle = True
   .Axes(xlValue, xlPrimary).AxisTitle.Text = Anzahl
   .Axes(xlValue, xlPrimary).AxisTitle.AutoScaleFont = False
   .Axes(xlValue, xlPrimary).AxisTitle.Font.Size = 12
   .Axes(xlValue).TickLabels.NumberFormat = 0
   .Axes(xlValue).TickLabels.AutoScaleFont = False
   .Axes(xlValue).TickLabels.Font.Size = 12
   
      
   If .Axes(xlValue).MaximumScale <= 5 Then
    .Axes(xlValue).MinimumScaleIsAuto = True
    .Axes(xlValue).MaximumScale = 5
    .Axes(xlValue).MinorUnitIsAuto = True
    .Axes(xlValue).MajorUnit = 1
   ElseIf .Axes(xlValue).MaximumScale <= 10 Then
    .Axes(xlValue).MinimumScaleIsAuto = True
    .Axes(xlValue).MaximumScale = 10
    .Axes(xlValue).MinorUnitIsAuto = True
    .Axes(xlValue).MajorUnit = 2
   ElseIf .Axes(xlValue).MaximumScale <= 16 Then
    .Axes(xlValue).MinimumScaleIsAuto = True
    .Axes(xlValue).MaximumScale = 16
    .Axes(xlValue).MinorUnitIsAuto = True
    .Axes(xlValue).MajorUnit = 2
   ElseIf .Axes(xlValue).MaximumScale <= 20 Then
    .Axes(xlValue).MinimumScaleIsAuto = True
    .Axes(xlValue).MaximumScale = 20
    .Axes(xlValue).MinorUnitIsAuto = True
    .Axes(xlValue).MajorUnit = 4
   ElseIf .Axes(xlValue).MaximumScale <= 50 Then
    .Axes(xlValue).MinimumScaleIsAuto = True
    .Axes(xlValue).MaximumScale = 50
    .Axes(xlValue).MinorUnitIsAuto = True
    .Axes(xlValue).MajorUnit = 10
   End If
   .Legend.AutoScaleFont = False
   .Legend.Font.Size = 10
   .Axes(xlCategory).TickLabels.AutoScaleFont = False
   .Axes(xlCategory).TickLabels.Font.Size = 7
   .Axes(xlCategory).TickLabels.Orientation = xlDownward
  End With
  ch.Location Where:=xlLocationAsObject, Name:=ws.Name
  
 ->Position des Charts setzen
  Set cho = ws.ChartObjects(ws.ChartObjects.Count)
  With cho
   .Left = ws.Cells(l_Start_zeile, l_linkeSpalte).Left
   .Top = ws.Cells(l_Start_zeile, l_linkeSpalte).Top
   .Width = ws.Cells(l_Start_zeile, l_linkeSpalte + l_BreiteInSpalten).Left - _
        ws.Cells(l_Start_zeile, l_linkeSpalte).Left
   .Height = ws.Cells(l_Start_zeile + l_HoeheInZeilen, l_linkeSpalte).Top - _
        ws.Cells(l_Start_zeile, l_linkeSpalte).Top
  End With
  
 ->Diagramm größer nächste freie Zeile ?
  If l_zeile < l_Start_zeile + l_HoeheInZeilen Then
   l_zeile = l_Start_zeile + l_HoeheInZeilen
  End If
  
 ->aufräumen
  Set cho = Nothing: Set ch = Nothing
End Function

Tabelle:

Datum Anz. rot Anz. gelb Anz. grün Anz. nicht relevant Anz. nicht bewertet Anz. Maßnahmen
07.07.2005 0 0 0 0 0 0
08.08.2005 0 0 0 0 0 0
21.09.2005 6 4 0 1 0 5
25.10.2005 6 0 4 1 0 3

Nun möchte ich dass die Spalte mit Anz. Maßnahmen als Sekundärachse dargestellt wird. Die Sekundärachse soll als liniendiagramm erzeugt werden.

Könnt Ihr mir da helfen?

Vielen Dank im Voraus

Grüße
falcon30
 
  • #2
Hi,

ich habe was vergessen.

Nicht nur Anz. Maßnahmen sondern noch weitere 2 Spalten, die hier nicht dargestellt sind, sollen als Liniendiagramm dargestellt werden.

Danke!!

Grüße
falcon30
 
  • #3
Hallo falcon30,

gestapelte Balken und Linie geht glaub ich nicht  :mad:
zumindest kenn ich keinen Weg dahin.

Als Alternative könnte ich dir Säulen mit Linien anbieten.

Gruß Matjes :)
 
  • #4
Hallo Matjes,

ich habe das ganze jetzt so gelöst:

Code: 
 Set ch = wb.Charts.Add
    With ch
      .ChartType = xlColumnStacked
      .SetSourceData Source:=r, PlotBy:=xlColumns
      .HasTitle = True
      .ChartTitle.Text = s_AddTextUberschrift
      .ChartTitle.AutoScaleFont = False
      .ChartTitle.Font.Size = 12
      .Axes(xlCategory, xlPrimary).HasTitle = False
      .Axes(xlValue, xlPrimary).HasTitle = True
      .Axes(xlValue, xlPrimary).AxisTitle.Text = Anzahl Prozesse
      .Axes(xlValue, xlPrimary).AxisTitle.AutoScaleFont = False
      .Axes(xlValue, xlPrimary).AxisTitle.Font.Size = 12
      .Axes(xlValue).TickLabels.NumberFormat = 0
      .Axes(xlValue).TickLabels.AutoScaleFont = False
      .Axes(xlValue).TickLabels.Font.Size = 12
      
      .SeriesCollection(1).Interior.ColorIndex = 3
      .SeriesCollection(1).Interior.Pattern = xlSolid
      .SeriesCollection(2).Interior.ColorIndex = 36
      .SeriesCollection(2).Interior.Pattern = xlSolid
      .SeriesCollection(3).Interior.ColorIndex = 4
      .SeriesCollection(3).Interior.Pattern = xlSolid
      .SeriesCollection(4).Interior.ColorIndex = 1
      .SeriesCollection(4).Interior.Pattern = xlSolid
      .SeriesCollection(5).Interior.ColorIndex = 48
      .SeriesCollection(5).Interior.Pattern = xlSolid
      
'### Linienchart Sekundärachse

      .SeriesCollection(6).Interior.ColorIndex = 33
      .SeriesCollection(6).Interior.Pattern = xlSolid
      .SeriesCollection(6).ChartType = xlLineMarkersStacked
      .SeriesCollection(6).AxisGroup = 2
      .Axes(xlValue, xlSecondary).HasTitle = True
      .Axes(xlValue, xlSecondary).AxisTitle.Characters.Text = Anz. Maßnahmen, Q und quant.
      .Axes(xlValue, xlSecondary).AxisTitle.AutoScaleFont = False
      .Axes(xlValue, xlSecondary).AxisTitle.Font.Size = 7
      
      
      .SeriesCollection(7).Interior.ColorIndex = 20
      .SeriesCollection(7).Interior.Pattern = xlSolid
      .SeriesCollection(7).ChartType = xlLineMarkersStacked
      .SeriesCollection(7).AxisGroup = 2
      
      .SeriesCollection(8).Interior.ColorIndex = 20
      .SeriesCollection(8).Interior.Pattern = xlSolid
      .SeriesCollection(8).ChartType = xlLineMarkersStacked
      .SeriesCollection(8).AxisGroup = 2[/color]    
 
'###
    
      If .Axes(xlValue).MaximumScale <= 5 Then
        .Axes(xlValue).MinimumScaleIsAuto = True
        .Axes(xlValue).MaximumScale = 5
        .Axes(xlValue).MinorUnitIsAuto = True
        .Axes(xlValue).MajorUnit = 1
      ElseIf .Axes(xlValue).MaximumScale <= 10 Then
        .Axes(xlValue).MinimumScaleIsAuto = True
        .Axes(xlValue).MaximumScale = 10
        .Axes(xlValue).MinorUnitIsAuto = True
        .Axes(xlValue).MajorUnit = 2
      ElseIf .Axes(xlValue).MaximumScale <= 16 Then
        .Axes(xlValue).MinimumScaleIsAuto = True
        .Axes(xlValue).MaximumScale = 16
        .Axes(xlValue).MinorUnitIsAuto = True
        .Axes(xlValue).MajorUnit = 2
      ElseIf .Axes(xlValue).MaximumScale <= 20 Then
        .Axes(xlValue).MinimumScaleIsAuto = True
        .Axes(xlValue).MaximumScale = 20
        .Axes(xlValue).MinorUnitIsAuto = True
        .Axes(xlValue).MajorUnit = 4
      ElseIf .Axes(xlValue).MaximumScale <= 50 Then
        .Axes(xlValue).MinimumScaleIsAuto = True
        .Axes(xlValue).MaximumScale = 50
        .Axes(xlValue).MinorUnitIsAuto = True
        .Axes(xlValue).MajorUnit = 10
      End If
      .Legend.AutoScaleFont = False
      .Legend.Font.Size = 10
      .Axes(xlCategory).TickLabels.AutoScaleFont = False
      .Axes(xlCategory).TickLabels.Font.Size = 7
      .Axes(xlCategory).TickLabels.Orientation = xlDownward
    End With
    ch.Location Where:=xlLocationAsObject, Name:=ws.Name

Gibt es eine Möglichkeit das ganze zu vereinfachen?

Grüße
falcon30
 
  • #6
Hallo falcon30,

ich hab dir eine Function zusammengestellt, die den bisherigen ähnelt.
Ein Parameter ist hinzugekommen:  l_abNr_SeriousCollection_SecondaryAxis

Der Aufruf wäre dann beispielsweide so, wenn ab SeriousCollection(6) die Reihen auf die Sekundärachse geschoben werden sollen:
Code: 
Call LinienSaeulenChartErstellenMitSekundaerAchse( _
    wb, ws, r, 6, l_Start_zeile, l_Stop_zeile, l_zeile, 1, 12, 10, s_AddText)

Eine Besonderheit ist noch zu nennen:
Ich habe die Zeitachse für die Darstellung auf monatsweise (.BaseUnit = xlMonths) gestellt, damit die Balken auch zu sehen sind. Läßt man Excel freien Lauf, stellt es bei einem genügend großen Zeitraum auf tageweise (xlDays) Darstellung um. Dann sehen die Balken etwas sehr mickrig, um nicht zu sagen Sch.. aus.  Mit Überdeckung kann man dann auch nichts mehr retten. :mad: 

Die monatsweise Darstellung hat aber den Nachteil, daß, wenn 2 Datensätze im gleichem Monat/Jahr liegen, der Stapelbalken des höheren Datums den anderen verdeckt . Sie werden halt beide auf dieselbe Stelle der Zeitachse gezeichnet.    :(

Gruß Matjes :)
Code: 
Function LinienSaeulenChartErstellenMitSekundaerAchse(wb As Workbook, ws As Worksheet, _
                              r As Range, _
                              l_abNr_SeriousCollection_SecondaryAxis As Long, _
                              l_Start_zeile, l_Stop_zeile, _
                              l_zeile As Long, _
                              l_linkeSpalte As Long, _
                              l_HoeheInZeilen As Long, _
                              l_BreiteInSpalten As Long, _
                              s_AddTextUberschrift As String)
    
   ->*********************************************************************************************
   ->*** l_abNr_SeriousCollection_SecondaryAxis
   ->*** Nr der SeriousCollection, ab der die reihen auf die Sekundäre Achse geschoben werden
    
    Dim ch As Chart, cho As ChartObject, x As Long
    
   ->Chart erzeugen
    Set ch = wb.Charts.Add
    With ch
      .ChartType = xlColumnStacked
      .SetSourceData Source:=r, PlotBy:=xlColumns
      .HasTitle = True
      .ChartTitle.Text = s_AddTextUberschrift
      .ChartTitle.AutoScaleFont = False
      .ChartTitle.Font.Size = 12
    End With
    
    With ch.Axes(xlCategory, xlPrimary)
      .HasTitle = False
    End With
    
    With ch.Axes(xlValue, xlPrimary)
      .HasTitle = True
      .HasMajorGridlines = True
      .HasMinorGridlines = False
    End With
    With ch.Axes(xlValue, xlPrimary).AxisTitle
      .Text = Anzahl Prozesse
      .AutoScaleFont = False
      .Font.Size = 10
    End With
    With ch.Axes(xlValue, xlPrimary).TickLabels
      .NumberFormat = 0
      .AutoScaleFont = False
      .Font.Size = 10
    End With
    
    With ch.SeriesCollection(1).Interior: .ColorIndex = 3: .Pattern = xlSolid: End With
    With ch.SeriesCollection(2).Interior: .ColorIndex = 36: .Pattern = xlSolid: End With
    With ch.SeriesCollection(3).Interior: .ColorIndex = 4: .Pattern = xlSolid: End With
    With ch.SeriesCollection(4).Interior: .ColorIndex = 1: .Pattern = xlSolid: End With
    With ch.SeriesCollection(5).Interior: .ColorIndex = 48: .Pattern = xlSolid: End With
    With ch.SeriesCollection(6).Interior: .ColorIndex = 33: .Pattern = xlSolid: End With
    With ch.SeriesCollection(7).Interior: .ColorIndex = 20: .Pattern = xlSolid: End With
    With ch.SeriesCollection(8).Interior: .ColorIndex = 20: .Pattern = xlSolid: End With



    If l_abNr_SeriousCollection_SecondaryAxis > 1 Then
     ->entsprechend ab Nr l_abNr_SeriousCollection_SecondaryAxis auf sekundäre Achse schieben
      For x = l_abNr_SeriousCollection_SecondaryAxis To ch.SeriesCollection.Count
        With ch.SeriesCollection(x)
          .AxisGroup = xlSecondary
          .ChartType = xlLineMarkersStacked
        End With
      Next
      
      ch.Axes(xlValue, xlSecondary).HasTitle = True
      With ch.Axes(xlValue, xlSecondary).AxisTitle
        .Text = Anz. Maßnahmen, & vbLf & Q und quant.
        .AutoScaleFont = False
        .Font.Size = 7
      End With
      With ch.Axes(xlValue, xlSecondary).TickLabels
        .NumberFormat = 0
        .AutoScaleFont = False
        .Font.Size = 7
      End With
    End If
    With ch.Axes(xlValue, xlPrimary)
      If .MaximumScale <= 5 Then
        .MinimumScaleIsAuto = True: .MaximumScale = 5: .MinorUnitIsAuto = True: .MajorUnit = 1
      ElseIf .MaximumScale <= 10 Then
        .MinimumScaleIsAuto = True: .MaximumScale = 10: .MinorUnitIsAuto = True: .MajorUnit = 2
      ElseIf .MaximumScale <= 20 Then
        .MinimumScaleIsAuto = True: .MaximumScale = 20: .MinorUnitIsAuto = True: .MajorUnit = 4
      ElseIf .MaximumScale <= 50 Then
         .MinimumScaleIsAuto = True: .MaximumScale = 50: .MinorUnitIsAuto = True: .MajorUnit = 10
      End If
    End With
    If l_abNr_SeriousCollection_SecondaryAxis > 1 Then
      With ch.Axes(xlValue, xlSecondary)
        If .MaximumScale <= 5 Then
          .MinimumScaleIsAuto = True: .MaximumScale = 5: .MinorUnitIsAuto = True: .MajorUnit = 1
        ElseIf .MaximumScale <= 10 Then
          .MinimumScaleIsAuto = True: .MaximumScale = 10: .MinorUnitIsAuto = True: .MajorUnit = 2
        ElseIf .MaximumScale <= 20 Then
          .MinimumScaleIsAuto = True: .MaximumScale = 20: .MinorUnitIsAuto = True: .MajorUnit = 4
        ElseIf .MaximumScale <= 50 Then
          .MinimumScaleIsAuto = True: .MaximumScale = 50: .MinorUnitIsAuto = True: .MajorUnit = 10
        End If
      End With
    End If
    
    With ch.Axes(xlCategory)
        .BaseUnit = xlMonths
    End With
    
    With ch.Legend
      .AutoScaleFont = False: .Font.Size = 10
    End With
    With ch.Axes(xlCategory).TickLabels
      .AutoScaleFont = False: .Font.Size = 7: .Orientation = xlDownward
    End With

    ch.Location Where:=xlLocationAsObject, Name:=ws.Name
    
   ->Position des Charts setzen
    Set cho = ws.ChartObjects(ws.ChartObjects.Count)
    With cho
      .Left = ws.Cells(l_Start_zeile, l_linkeSpalte).Left
      .Top = ws.Cells(l_Start_zeile, l_linkeSpalte).Top
      .Width = ws.Cells(l_Start_zeile, l_linkeSpalte + l_BreiteInSpalten).Left - _
               ws.Cells(l_Start_zeile, l_linkeSpalte).Left
      .Height = ws.Cells(l_Start_zeile + l_HoeheInZeilen, l_linkeSpalte).Top - _
                ws.Cells(l_Start_zeile, l_linkeSpalte).Top
    End With
    
   ->Diagramm größer nächste freie Zeile ?
    If l_zeile < l_Start_zeile + l_HoeheInZeilen Then
      l_zeile = l_Start_zeile + l_HoeheInZeilen
    End If
    
   ->aufräumen
    Set cho = Nothing: Set ch = Nothing
End Function
 
  • #7
Hallo Matjes,

vielen Dank!!

Grüße
falcon30
 
Thema:

Excel Makro Sekundärachse als Liniendiagramm

ANGEBOTE & SPONSOREN

Neueste Themen

Statistik des Forums

Themen
113.840
Beiträge
707.963
Mitglieder
51.494
Neuestes Mitglied
Flensburg45
Oben