Excel03 - Farbzuordnung Kuchendiagramm

19/08/2008 - 22:52 von René Panzeri | Report spam
Hallo zusammen

Ich bitte Euch um Hilfe bei einem Kuchendiagramm, welches mit Daten aus
einer Access-Datenbank erstellt werden soll. Gegeben ist ein Code, eine
Menge und eine Farbe pro Code:
F0 - 10 - Rot [Color 3]
F1 - 5 - Blau [Color 5]
F2 - 17 - Grün [Color 10]
F3 - 11 - Orange [Color 46]
F4 - 20 - Gelb [Color 6]



In den Auswertungen kommen nicht immer alle Codes vor. Die Kuchenstücke
müssen jedoch immer die pro Code vorgegebene Farbe haben. Wenn also eine
Auswertung mit den Code F0 (10), F2 (17), F4 (20) dargestellt werden
muss, so sollen die Kuchenstücke in den Farben rot, grün und gelb sein.

Ich habe ausgegooglet und danke Euch für Euren Input, wie ich das mit
VBA lösen kann.

René
 

Lesen sie die antworten

#1 René Panzeri
21/08/2008 - 12:09 | Warnen spam
René Panzeri schrieb:

Ich bitte Euch um Hilfe bei einem Kuchendiagramm, welches mit Daten aus
einer Access-Datenbank erstellt werden soll. Gegeben ist ein Code, eine
Menge und eine Farbe pro Code:
F0 - 10 - Rot [Color 3]
F1 - 5 - Blau [Color 5]
F2 - 17 - Grün [Color 10]
F3 - 11 - Orange [Color 46]
F4 - 20 - Gelb [Color 6]



Hallo zusammen

Für alle die es interessieren könnte, gebe ich Euch eine Rückmeldung,
wie es inzwischen gelöst habe. Der Datenexport samt Farbindex erfolgt
aus einer Access-Datenbank mit LateBinding:

Private Const PrivConst_xlColumns = 2
Private Const PrivConst_xlDataLabelsShowLabel = 4

Public Sub Farbgrafik()
On Error GoTo Level_Error

Dim prst As DAO.Recordset

Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim xlSheets As Object

Dim IsExcelOpen As Boolean
Dim IsWorkbookOpen As Boolean

Dim pstrDbPfad As String
Dim pstrKriterium As String
Dim DataLabel As String
Dim pstrDateiname As String
Dim rCount As Long
Dim i As Long 'Counter
Dim x As Integer 'Points.Count
Dim z As Integer 'SeriesCollection.Count

'Recordset definieren
Set prst = CurrentDb.OpenRecordset("Abfrage1", dbOpenDynaset)

'Aktueller Datenbankpfad
pstrDbPfad = Left(CurrentDb.Name, Len(CurrentDb.Name) -
Len(Dir(CurrentDb.Name)))

'Recordset prüfen
rCount = prst.RecordCount
If rCount = 0 Then
MsgBox "Es sind keine Daten für den Export verfügbar.", vbCritical
Exit Sub
End If

'Excel öffnen
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
Else
IsExcelOpen = True
End If
On Error GoTo 0

'Dateiname speichern
pstrDateiname = "Kuchengrafik.xls"

'Geöffnetes xlBook prüfen
For Each xlBook In xlApp.Workbooks
If xlBook.Name = pstrDateiname Then
IsWorkbookOpen = True
End If
Next

'xlBook öffnen/aktivieren
If Not IsWorkbookOpen Then
Set xlBook = xlApp.Workbooks.Open(pstrDbPfad & pstrDateiname)
Else
Set xlBook = xlApp.Workbooks(pstrDateiname)
End If

xlBook.Activate
'Daten nach Excel exportieren
Set xlSheet = xlBook.Worksheets(2)
xlSheet.Activate

'Bestehende Inhalte löschen
xlApp.Range("A:C").ClearContents

'Daten aus Recordset einlesen
xlSheet.cells(2, 1).copyfromrecordset prst

'1. Zeile fett
xlApp.Range("1:1").Font.Bold = True

'Spaltenüberschriften aus Recordset
For i = 0 To prst.Fields.Count - 1
xlBook.ActiveSheet.cells(1, i + 1) = prst(i).Name
Next i

'Zahlentotalisierung
With xlApp.Worksheets(2)
.Range("B" & rCount + 2).Select
xlApp.ActiveCell.FormulaR1C1 = "=SUM(R[" & -rCount & "]C:R[-1]C)"
End With

xlSheet.Range("B" & rCount + 2 & ":B" & rCount + 2 & "").Font.Bold
= True

'Sheet aktivieren
Set xlSheet = xlBook.Worksheets(1)
xlSheet.Activate

'Chart formatieren
xlApp.ScreenUpdating = False
xlApp.ActiveSheet.ChartObjects(1).Activate
xlApp.ActiveChart.ChartArea.Select
'Datenquelle gemàss Recordcount neu definieren
On Error Resume Next

Set xlSheets = xlApp.Sheets
xlApp.ActiveChart.SetSourceData
Source:=xlSheets("ClientIS-Daten").Range("A1:B" & rCount + 1 & ""),
PlotBy:=PrivConst_xlColumns
On Error GoTo 0
'Chart umstellen auf ShowLabel
xlApp.ActiveChart.SeriesCollection(1).ApplyDataLabels
Type:=PrivConst_xlDataLabelsShowLabel, AutoText:=True

'Alle SeriesCollection durchlaufen
For z = 1 To xlApp.ActiveChart.SeriesCollection.Count
'Alle Point durchalufen
For x = 1 To xlApp.ActiveChart.SeriesCollection(z).Points.Count

xlApp.ActiveChart.SeriesCollection(z).Points(x).DataLabel.Select
'Datalabel auslesen
DataLabel = xlApp.Selection.Text
'Suchkritierum festlegen
pstrKriterium = "Kürzel=""" & DataLabel & """"
'Suchkriterium aus Recordset auslesen
prst.FindFirst pstrKriterium
'Farbindex aus Recordset in XLS übertragen

xlApp.ActiveChart.SeriesCollection(z).Points(x).Interior.ColorIndex =
prst!Farbindex
Next x
Next z

'Legende wieder auf "Name + Prozent" setzen
xlApp.ActiveChart.ApplyDataLabels AutoText:=True, LegendKey:=False, _
HasLeaderLines:=True, ShowSeriesName:=False,
ShowCategoryName:=False, _
ShowValue:=True, ShowPercentage:=True, ShowBubbleSize:=False,
Separator _
:="" & Chr(10) & ""
xlApp.ScreenUpdating = True

'1. Zelle aktivieren
xlSheet.Range("A1").Select
xlApp.Visible = True

Level_Exit:
On Error Resume Next
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp= Nothing
prst.Close: Set prst = Nothing
Exit Sub

Level_Error:
MsgBox Err.Description
Resume Level_Exit

End Sub

Ähnliche fragen