Consulting

Results 1 to 2 of 2

Thread: VBA Create Diagramms

  1. #1

    VBA Create Diagramms

    I want to create multiple diagrams outomatically. Does somebody know how to debug?

    Sub MakroTest()
    
    Dim MyWorksheet As Worksheet
    Dim i As Integer
    Dim DL As Long
    
    Set MyWorksheet = ActiveSheet
    
    DL = MyWorksheet.Cells(Rows.Count, 1).End(xlUp).Row
    
    
    For i = 2 To DL 'end of the liste
    'if only do it if i equals to this excel eqaution: =AND(ROW()>1;INDEX(A:A;ROW())=INDEX(A:A;ROW()-1))
        ActiveSheet.Shapes.AddChart2(201, xlColumnClustered).Select
        ActiveChart.SetSourceData Source:=Range("A1:C1,A"&i"C"&i) 'i know that here is an error
        ActiveChart.ApplyChartTemplate ( _
            "C:\Users\[...]\Microsoft\Templates\Charts\InvestImpact Diagramm.crtx" _
            )
        
        
    Next
    
    End Sub

  2. #2
    Thats the solution:

    Sub DiagrammErstellen()
    
    Dim DL As Integer '#Zeilen
    Dim i As Integer ' Zeilen Laufindex
    
    Dim sheet As Worksheet
    
    Set MyWorksheet = ThisWorkbook.Sheets("KPI")
    Application.CutCopyMode = False
    
    DL = Cells(Rows.Count, 1).End(xlUp).Row
    
    For i = 2 To DL
    
    If Cells(14, i) = FALSCH Then
    
    With MyWorksheet.Shapes.AddChart2(216, xlBarClustered)
    
    
    '--------Größe und Position------
    .Width = 200
    .Height = 50
    .Top = Cells(i, 2).Top
    .Left = Cells(i, 2).Left
    
    '----------Layout--------------
    .Fill.Visible = msoFalse
    .Line.Visible = msoFalse
    
    With .Chart
    .ChartArea.ClearContents
    .SeriesCollection.NewSeries
    
        With .FullSeriesCollection(1)
    
            .Name = "=Pivot! " & Cells(i, 1).Address
            .Values = "=Pivot!" & Range(Cells(i, 2), Cells(i, 3)).Address
            .XValues = "=Pivot!" & Range(Cells(1, 2), Cells(1, 3)).Address
            
            End With
            
    .SetElement (msoElementPrimaryValueGridLinesNone)
    .SetElement (msoElementDataLabelOutSideEnd)
    .ChartGroups(1).GapWidth = 0
    .ChartTitle.Delete
    .Axes(xlValue).Delete
    .Axes(xlCategory).Delete
    
    .PlotArea.Select
    Selection.Left = 0
    
    
    ''---------Layout2-------- Balken 1 bei selection format line braucht man nicht alles
    .FullSeriesCollection(1).Points(2).Select
      With Selection.Format.Fill
            .Visible = msoTrue
            .ForeColor.RGB = RGB(205, 219, 229)
            .Transparency = 0
            .Solid
        End With
        With Selection.Format.Line
            .Visible = msoTrue
            .ForeColor.ObjectThemeColor = msoThemeColorAccent1
            .ForeColor.TintAndShade = 0
            .ForeColor.RGB = RGB(0, 0, 0)
            .ForeColor.Brightness = 0
        End With
        
    ActiveChart.FullSeriesCollection(1).Points(1).Select
    
        With Selection.Format.Fill
            .Visible = msoTrue
            .ForeColor.RGB = RGB(180, 202, 216)
            .Transparency = 0
            .Solid
        End With
        With Selection.Format.Line
            .Visible = msoTrue
            .ForeColor.ObjectThemeColor = msoThemeColorText1
            .ForeColor.TintAndShade = 0
            .ForeColor.RGB = RGB(0, 0, 0)
            .ForeColor.Brightness = 0
            .Transparency = 0
       
        '.HasLegend = False
        End With
        
        End With
        
        End With
          
    End If
    Next i
    
    End Sub

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •