#Bubble #Pies oder #Kreise in #Blasen – daswirdimmerschöner


Ihnen haben die Kreisdiagramme in den Blasendiagrammen gefallen?

XTipp BubblePies 01Ein 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

 

Über katharinakanns

Microsoft Office Master Specialist mit viel Verständnis für IHR Geschäft - ich analysiere IHRE Situation, optimiere IHRE Prozesse, automatisiere IHRE Routineaufgaben, finde IHRE Lösung, unterrichte IHRE MitarbeiterInnen, mache Vorlagen mit IHRER CI, spare IHRE Zeit und IHR Geld. Ich freue mich darauf, SIE kennenlernen zu dürfen :-)
Dieser Beitrag wurde unter Excel, VBA abgelegt und mit , , , , verschlagwortet. Setze ein Lesezeichen auf den Permalink.

Kommentar verfassen

Trage deine Daten unten ein oder klicke ein Icon um dich einzuloggen:

WordPress.com-Logo

Du kommentierst mit Deinem WordPress.com-Konto. Abmelden / Ändern )

Twitter-Bild

Du kommentierst mit Deinem Twitter-Konto. Abmelden / Ändern )

Facebook-Foto

Du kommentierst mit Deinem Facebook-Konto. Abmelden / Ändern )

Google+ Foto

Du kommentierst mit Deinem Google+-Konto. Abmelden / Ändern )

Verbinde mit %s