With this code diagrams with data from all used columns are provided. The pie charts are on separate chart sheets. A UserForm is faded in during the program sequence. The files at the end of the article are Excelfiles of the version 2003 and 2007. The following code belonged in "UserForm1", "Module1".

Mit diesem Code werden Diagramme mit Daten aus allen benutzten Spalten erstellt. Die Kreisdiagramme sind auf separaten Diagrammsheets. Eine UserForm wird während des Programmablaufes eingeblendet. Die Dateien am Ende des Artikels sind Exceldateien der Version 2003 und 2007. Der folgende Code gehört in "UserForm1", "Modul1".

Option Explicit
Private Sub UserForm_Activate()
Dim shpChartSheet As Object
Dim intPoints As Integer
Dim objSheet As Object
Dim shpChart As Object
Dim rngRange As Range
Dim intTMP As Integer
Dim lngRow As Long
On Error GoTo Fin
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each objSheet In ThisWorkbook.Sheets
If objSheet.Type <> xlWorksheet Then
End If
Next objSheet
With Sheet1 'adapt
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For intTMP = 2 To .Cells.Find _
("*", , , , xlByColumns, xlPrevious).Column
Set rngRange = .Application.Union _
(.Range(.Cells(1, 1), .Cells(lngRow, 1)), _
.Range(.Cells(1, intTMP), .Cells(lngRow, intTMP)))
Set shpChart = .Shapes.AddChart
shpChart.Chart.SetSourceData Source:=rngRange
shpChart.Chart.HasTitle = True
shpChart.Chart.ChartTitle.Characters.Text = _
.Cells(1, intTMP).Value
shpChart.Chart.SeriesCollection(1).HasDataLabels = True
shpChart.Chart.ChartType = xlPie
shpChart.Chart.Location Where:=xlLocationAsNewSheet, _
Name:=.Cells(1, intTMP).Value
Sheets(.Cells(1, intTMP).Value).Move _
Set shpChartSheet = Charts(intTMP - 1)
With shpChartSheet.SeriesCollection(1)
For intPoints = 1 To .Points.Count
.Points(intPoints).DataLabel.ShowCategoryName = True
' 2 = xlLabelPositionOutsideEnd
.Points(intPoints).DataLabel.Position = 2
Next intPoints
End With
Set rngRange = Nothing
Set shpChart = Nothing
Next intTMP
End With
Application.Goto Sheet1.Range("A1"), True 'adapt
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Unload Me
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
End Sub

Option Explicit
Public Sub Test()
End Sub

Sample 2003

Sample 2007

Keine Kommentare:

Kommentar veröffentlichen

PowerPoint - Fusszeile - TextBox befüllen - alle Folien...

PowerPoint alle Folien - in der Fusszeile die Textbox befüllen. PowerPoint all slides - fill the text box in the footer. Hier noch eine ...