Excel Makro Sekundärachse als Liniendiagramm

Dieses Thema Excel Makro Sekundärachse als Liniendiagramm im Forum "Microsoft Office Suite" wurde erstellt von falcon30, 9. Nov. 2005.

Thema: Excel Makro Sekundärachse als Liniendiagramm Hallo Zusammen, ich habe eine Tabelle mit der per Makro ein Diagramm erzeugt wird. Makro: Function...

  1. 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
     
  5. 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
     
  6. Hallo Matjes,

    vielen Dank!!

    Grüße
    falcon30
     
Die Seite wird geladen...

Excel Makro Sekundärachse als Liniendiagramm - Ähnliche Themen

Forum Datum
Excel VBA Makro zum suchen eines Textes und anschließend einen Breich zu kopieren Microsoft Office Suite 22. Jan. 2015
Excel VBA Makro zum suchen und markieren von Zeilen die ein bestimmtes Wort enthalten Microsoft Office Suite 16. Juni 2014
Excel: Makro ASCII verschieben Windows XP Forum 8. Nov. 2013
Makros und anderes - Excel Microsoft Office Suite 15. März 2013
Excel Sprungmarke mitten in ein anderes Makro Windows XP Forum 15. März 2012