Soprani Software

Ihnen haben die Kreisdiagramme in den Blasendiagrammen gefallen?

Ein bisschen hab ich den Code (Punkt 4) inzwischen verfeinert. Und zwar:

• Parameter ergänzt – damit lässt sich die Prozedur für unterschiedliche Diagramme und unterschiedliche Datenbereiche verwenden
• Beispielfarben fixiert – wenn Sie im Beispiel die Farben ändern, gehen sie nicht „unterwegs“ verloren
• Pause eingefügt – damit das Kreisdiagramm nicht „fotografiert“ wird, bevor es fertig hergerichtet ist
• beliebige Datenreihe aus dem Wertebereich als Quelle für den Beispielkreis ermöglicht (damit Sie in der Vorbereitung keine Nullwerte haben)

Sub PieMarkers1()
    Call PieMarkers("BspKreis", "ErgBlasen", "KreisWerte")
End Sub

Sub PieMarkers2()
    Call PieMarkers("BspKreis2", "ErgBlasen2", "KreisWerte2")
End Sub

Sub PieMarkers(Name_Pie As Variant, Name_Bubbles As Variant, Name_Values As Variant)

Dim myPie As Chart
Dim myBubbles As Chart
Dim myRow As Range
Dim Point_I As Long
Dim I As Long
Dim mySh As Worksheet
Dim numCols As Long
Dim myAcc() As Long
Dim myRGB() As Long
Dim waitTime As Date
Dim I_Row As Long

    Set mySh = ActiveSheet
    Set myPie = mySh.ChartObjects(Name_Pie).Chart
    Set myBubbles = mySh.ChartObjects(Name_Bubbles).Chart
    Point_I = 0
    numCols = Range(ThisWorkbook.Names(Name_Values).RefersTo).Rows(1).Cells.Count
    ReDim myAcc(numCols)
    ReDim myRGB(numCols)
    For I = 1 To numCols
        With myPie.SeriesCollection(1).Points(I).Format.Fill
            myAcc(I) = .ForeColor.ObjectThemeColor
            myRGB(I) = .ForeColor.RGB
        End With
    Next I
    I_Row = Val(Mid(myPie.SeriesCollection(1).FormulaR1C1, InStr(1, myPie.SeriesCollection(1).FormulaR1C1, "!R") + 2, 3)) _
    - Range(ThisWorkbook.Names(Name_Values).RefersTo).Row + 1
    For Each myRow In Range(Name_Values).Rows
        myPie.SeriesCollection(1).Values = myRow
        For I = 1 To myRow.Cells.Count
            With myPie.SeriesCollection(1).Points(I).Format.Fill
                If myAcc(I) <> 0 Then
                    .ForeColor.ObjectThemeColor = myAcc(I)
                End If
                .ForeColor.RGB = myRGB(I)
            End With
        Next I
        waitTime = DateAdd("s", 0.5, Now)
        Application.Wait waitTime
        myPie.Parent.CopyPicture xlScreen, xlPicture
        Point_I = Point_I + 1
        myBubbles.SeriesCollection(1).Points(Point_I).Paste
    Next
    myPie.SeriesCollection(1).Values = Range(Name_Values).Rows(I_Row)
    Application.ScreenUpdating = True

End Sub