Diagram!

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
DoEvents
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each objSheet In ThisWorkbook.Sheets
If objSheet.Type <> xlWorksheet Then
objSheet.Delete
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 _
After:=Sheets(Sheets.Count)
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
Fin:
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()
UserForm1.Show
End Sub


Sample 2003

Sample 2007

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...