Hier nun ein zweites Beispiel in etwas abgeänderter Form.
Neu hinzu gekommen ist der CommandButton2, mit dessen Hilfe die Trendlinie
von "Linear" auf "Polynomisch 2. Ordnung" und wieder zurück geändert werden
kann. Ausserdem ist in jedem Diagramm eine TextBox mit einem erklärenden Hinweis
auf die Trendlinie integriert. Der Hinweis ändert sich je nach Art der
Trendlinie, so dass der Betrachter immer informiert ist.
Wie im Diagramm-Programmbeispiel 1 wandern die CommandButtons mit der aktiven
Zeile mit, wenn sie einen chartfähigen Datensatz enthält. Die Buttons sind nur
dann auf "aktiv" gesetzt, wenn es auch einen Sinn ergibt.
Die Datenbasis ist die gleiche wie schon im Diagramm-Programmbeispiel 1.
Das betrifft auch die Art und Weise, wie die zugehörigen Maßeinheiten
für die Darstellung im Diagramm ausgelesen werden - der Vollständigkeit halber
hier in Teil 1 "Daten holen" aufgeführt.
08.10.2009: Außerdem ist der Code nun komplett überarbeitet und am Ende - im CommadButton2 - Teil
wird gezeigt
wie man auf das Diagramm ganz ohne "Select" und "Activate" zugreift.
Für Eilige: Sofort zum
Teil 2: Diagramme
Das Thema CommandButton wird dann wieder am Ende der Seite in
CommandButton2 und in
Worksheet_SelectionChange behandelt,
wo die Lage der Buttons gesteuert und dieselben ein- bzw. ausgeschaltet
werden.
Die Programme von Teil 2 sind im VBA-Editor im Codefenster des Diagramm-
und Auswahlsheets einzugeben. In einem normalen Modul würden die
Programme wegen des Bezugs auf den CommandButton so nicht
funktionieren. Hier wären geringfügige Änderungen notwendig.
Anzeigebeispiel
: Diagramme und die Auswahlliste (38KB)
Zusätzlich habe ich mich entschlossen, die komplette Excel-Datei
als Zip-File zum Download anzubieten, damit man das Beispiel live sehen kann.
Excel Datei als Zip-File zum Download (58KB)
08.10.2009: Die hier zum Download bereitgestellte Mappe
enthält noch den alten Code. Da jedoch die Funktionsweise und die Optik
der Diagramme grundsätzlich die gleiche ist, habe ich es mit dem Aufbereiten
dieser Mappe nicht besonders eilig. Wer möchte, kann sie ja zusätzlich
benutzen, um die Unterschiede Alt - Neu zu betrachten.
' Teil 1: Daten für die Diagramme holen ' Das gehört vom Thema her zwar nicht hier hin, soll aber ' gemäß der "Wühlkisten-Philosophie" und auch der Voll- ' ständigkeit halber hier aufgeführt werden. ' Mit den Diagrammen und den CommandButton's gehts dann in ' Teil 2 los. Option Explicit Private Const Monat1 As Integer = 9 Private Const Monat2 As Integer = 9 Private Const Jahr As String = 2009 Private Const ServerADR$ = "\\Servername\Verzeichnis\Unterverzeichnis1\Unterverzeichnis2\" & Jahr & "\" Private Mappe As Workbook 'Datenquelle Private Seite As Worksheet 'Datenquelle Private Ziel As Worksheet 'dieses Workbook (Analyse HiBe) Private I As Integer 'Schleifenzähler Private Zeile As Integer 'Einfügezeile in Analyse HiBe Tabelle1 Private Spalte As Integer 'Einfügespalte in Analyse HiBe Tabelle1 Sub HiBe_Analyse() ' Auslesen der Absolutverbräuche Menge Dim A As Variant Dim MatNr Dim B As Range Set Ziel = ThisWorkbook.Sheets("Tabelle1") Zeile = 3 Spalte = Monat1 + 2 For I = Monat1 To Monat2 Application.ScreenUpdating = False Application.EnableEvents = False ChDir ServerADR$ If I < 10 Then Workbooks.Open Filename:= _ ServerADR$ & "0" & I & " " & Jahr & ".xls" Else Workbooks.Open Filename:= _ ServerADR$ & I & " " & Jahr & ".xls" End If Set Mappe = ActiveWorkbook Set Seite = Mappe.Sheets(1) A = Application.WorksheetFunction.SumIf(Seite.Range("O:O"), "=2", Seite.Range("G:G")) Ziel.Cells(Zeile, Spalte).Value = A Zeile = Zeile + 1 Do Until Ziel.Cells(Zeile, 1).Value = "" MatNr = Ziel.Cells(Zeile, 1).Value 'MatNr = Ziel.Cells(Zeile, 17).Value 'für das Mapping alter Materialnummern Set B = Mappe.Sheets("Lager_400").Range("C:C").Find _ (MatNr, LookAt:=xlPart, LookIn:=xlFormulas) If Not B Is Nothing Then A = Mappe.Sheets("Lager_400").Range("H" & B.Row).Value Ziel.Cells(Zeile, Spalte).Value = A Else End If Zeile = Zeile + 1 Loop Spalte = Spalte + 1 Zeile = 3 Mappe.Close Application.EnableEvents = True Next I Application.ScreenUpdating = True Ziel.Range("C3").Activate End Sub
Sub HiBe_Analyse_Preise() ' Auslesen der Absolutverbräuche Wert Dim A As Variant Dim MatNr Dim B As Range Set Ziel = ThisWorkbook.Sheets("Tabelle1") Zeile = 68 Spalte = Monat1 + 2 For I = Monat1 To Monat2 Application.ScreenUpdating = False Application.EnableEvents = False ChDir ServerADR$ If I < 10 Then Workbooks.Open Filename:= _ ServerADR$ & "0" & I & " " & Jahr & ".xls" Else Workbooks.Open Filename:= _ ServerADR$ & I & " " & Jahr & ".xls" End If Set Mappe = ActiveWorkbook Set Seite = Mappe.Sheets(1) A = Application.WorksheetFunction.SumIf(Seite.Range("O:O"), "=2", Seite.Range("K:K")) Ziel.Cells(Zeile, Spalte).Value = A Zeile = Zeile + 1 Do Until Ziel.Cells(Zeile, 1).Value = "" MatNr = Ziel.Cells(Zeile, 1).Value 'MatNr = Ziel.Cells(Zeile, 17).Value 'für das Mapping alter Materialnummern Set B = Mappe.Sheets("Lager_400").Range("C:C").Find _ (MatNr, LookAt:=xlPart, LookIn:=xlFormulas) If Not B Is Nothing Then A = Mappe.Sheets("Lager_400").Range("J" & B.Row).Value Ziel.Cells(Zeile, Spalte).Value = A Else End If Zeile = Zeile + 1 Loop Spalte = Spalte + 1 Zeile = 68 Mappe.Close Application.EnableEvents = True Next I Application.ScreenUpdating = True End Sub
Sub HiBe_Analyse_QM() ' Auslesen der produzierten qm des Endproduktes Dim A(1) As Variant Set Ziel = ThisWorkbook.Sheets("Tabelle1") Zeile = 198 Spalte = Monat1 + 2 For I = Monat1 To Monat2 Application.ScreenUpdating = False Application.EnableEvents = False ChDir ServerADR$ If I < 10 Then Workbooks.Open Filename:= _ ServerADR$ & "0" & I & " " & Jahr & ".xls" Else Workbooks.Open Filename:= _ ServerADR$ & I & " " & Jahr & ".xls" End If Set Mappe = ActiveWorkbook Set Seite = Mappe.Sheets("Leimverbrauch") A(0) = Seite.Range("F18").Value / 1000000 'Normal + Doppel qm A(1) = Seite.Range("D18").Value / 1000000 'Normal qm Ziel.Cells(Zeile, Spalte).Value = A(0) Ziel.Cells(Zeile + 1, Spalte).Value = A(1) ActiveCell.Offset(0, 1).Select Mappe.Close Spalte = Spalte + 1 Application.EnableEvents = True Next I Application.ScreenUpdating = True End Sub
Option Explicit Private Sub CommandButton1_Click() ' Erzeugen und Formatieren der Grafiken Dim Datenreihe(5), Monate, B As Range 'B ist Basispunkt im Datensheet Dim Adresse As String 'Adressen der Datenreihen für Grafik 1 Dim Adresse2 As String 'Adressen der Datenreihen für Grafik 2 Dim Gname As String 'Name der aktiven Grafik Dim A As String 'Name von Datenreihe 1 Dim C As String 'Name von Datenreihe 3 Dim X As Integer 'Zeile des gewälten Datensatzes Dim Daten As Worksheet 'Datenbanksheet Dim Analyse As Worksheet 'Grafiksheet 'Dim Dia1, Dia2 As Integer ' aktive Zelle setzen (eigentlich nicht nötig: siehe Beschreibung) If ActiveCell.Column <> 2 Then Cells(ActiveCell.Row, 2).Select ' Ende aktive Zelle setzen ' Eigenschaften und Werte zuweisen X = ActiveCell.Row A = Range("B" & X).Value Set Analyse = Sheets("Analyse Hiebe (Grafik)") Set Daten = Sheets("Tabelle1") C = "Ø Preis/" & Daten.Cells(X, 2).Offset(130, 14).Value Set Monate = Sheets(1).Range(Cells(1, 3), Cells(1, 14)) Set Datenreihe(1) = Sheets(1).Range(Cells(X, 3), Cells(X, 14)) Set Datenreihe(2) = Sheets(1).Range(Cells(X + 65, 3), Cells(X + 65, 14)) Set Datenreihe(3) = Sheets(1).Range(Cells(X + 130, 3), Cells(X + 130, 14)) Set Datenreihe(4) = Sheets(1).Range(Cells(X + 201, 3), Cells(X + 201, 14)) Set Datenreihe(5) = Sheets(1).Range(Cells(199, 3), Cells(199, 14)) Set B = Cells(X, 2) Adresse = Monate.Address & ", " & Datenreihe(1).Address & ", " & Datenreihe(2).Address & ", " & Datenreihe(3).Address Adresse2 = Monate.Address & ", " & Datenreihe(5).Address & ", " & Datenreihe(4).Address ' Ende Eigenschaften und Werte zuweisen On Error GoTo Abbruch Application.ScreenUpdating = False ' vorhandene Diagramme löschen: Application.ActiveSheet.ChartObjects.Delete ' Ende vorhandene Diagramme löschen ' Diagramm hinzufügen und Typ festlegen: Charts.Add ActiveChart.Location Where:=xlLocationAsObject, Name:="Analyse Hiebe (Grafik)" ActiveChart.ChartType = xlLine ' Ende Diagramm hinzufügen und Typ festlegen ' Datenreihen zufügen, ausrichten und benennen: ActiveChart.Axes(xlValue).MinimumScale = 0 ActiveChart.SetSourceData Source:=Sheets("Tabelle1").Range( _ Adresse), PlotBy:=xlRows ActiveChart.SeriesCollection(1).Name = A ActiveChart.SeriesCollection(2).Name = "=""Kosten""" ActiveChart.SeriesCollection(3).Name = C ' Ende Datenreihen zufügen, ausrichten und benennen ' Trendlinie hinzufügen: ' ActiveChart.SeriesCollection(1).Select ' ActiveChart.SeriesCollection(1).Trendlines.Add(Type:=xlPolynomial, Order:=2, Forward:=0, _ Backward:=0, DisplayEquation:=False, DisplayRSquared:=False).Select ActiveChart.SeriesCollection(1).Trendlines.Add(Type:=xlLinear, Forward:=0, _ Backward:=0, DisplayEquation:=False, DisplayRSquared:=False).Select ActiveChart.SeriesCollection(1).Trendlines(1).Name = "Trend Verbauch" ' Ende Trendlinie hinzufügen ' Gitternetzlinien zufügen: With ActiveChart.Axes(xlCategory) .HasMajorGridlines = True .HasMinorGridlines = False End With With ActiveChart.Axes(xlValue) .HasMajorGridlines = True .HasMinorGridlines = False End With ' Ende Gitternetzlinien zufügen ' Legende und Datentabelle: ActiveChart.HasLegend = True ActiveChart.Legend.Select Selection.Position = xlBottom ActiveChart.HasDataTable = False ' Ende Legende und Datentabelle ' Chartlinien formatieren: ActiveChart.SeriesCollection(1).Select With Selection.Border .ColorIndex = 5 .Weight = xlMedium .LineStyle = xlContinuous End With With Selection .MarkerBackgroundColorIndex = xlNone .MarkerForegroundColorIndex = xlNone .MarkerStyle = xlNone .Smooth = False .MarkerSize = 3 .Shadow = False End With ActiveChart.SeriesCollection(2).Select With Selection.Border .ColorIndex = 57 .Weight = xlMedium .LineStyle = xlContinuous End With With Selection .MarkerBackgroundColorIndex = xlNone .MarkerForegroundColorIndex = xlNone .MarkerStyle = xlNone .Smooth = False .MarkerSize = 3 .Shadow = False .AxisGroup = 2 End With ActiveChart.SeriesCollection(3).Select With Selection.Border .ColorIndex = 57 .Weight = xlMedium .LineStyle = xlContinuous End With With Selection .AxisGroup = 2 .MarkerBackgroundColorIndex = xlNone .MarkerForegroundColorIndex = xlNone .MarkerStyle = xlNone .Smooth = False .MarkerSize = 3 .Shadow = False End With ' Ende Chartlinien formatieren ' Diagramm auf Bildschirm ausrichten: ActiveChart.ChartArea.Select Gname = Mid(ActiveChart.Name, 24, 100) ActiveSheet.Shapes(Gname).ScaleWidth 1.29, msoFalse, _ msoScaleFromTopLeft ActiveSheet.Shapes(Gname).IncrementLeft 67 ActiveSheet.Shapes(Gname).IncrementTop -140 ' Ende Diagramm auf Bildschirm ausrichten ' Legende formatieren ActiveSheet.ChartObjects(Gname).Activate ActiveChart.Legend.Select With Selection.Border .Weight = xlHairline .LineStyle = xlAutomatic End With Selection.Shadow = True With Selection.Interior .ColorIndex = 15 .PatternColorIndex = 1 .Pattern = xlSolid End With Selection.AutoScaleFont = True With Selection.Font .Name = "Arial" .FontStyle = "Fett" .Size = 10 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic .Background = xlAutomatic End With ' Ende Legende formatieren ' Erklärung für Trendlinie zufügen ActiveChart.Shapes.AddTextbox(msoTextOrientationHorizontal, 148.5, 0#, _ 192#, 13.5).Select Selection.Characters.Text = "Trendlinie = Linear" Selection.AutoScaleFont = False With Selection.Characters(Start:=1, Length:=19).Font .Name = "Arial" .FontStyle = "Standard" .Size = 10 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlTop .Orientation = xlHorizontal .AutoSize = False End With ' Ende Erklärung für Trendlinie zufügen Windows("Analyse HiBe-2009.xls").Activate B.Select '----------------------------------------------------------------- 'Diagramm 2: Ø Kosten / 1000qm A = A & " - Preis/1.000m²" ' Diagramm hinzufügen und Typ festlegen: Charts.Add ActiveChart.ChartType = xlLine ActiveChart.Location Where:=xlLocationAsObject, Name:="Analyse Hiebe (Grafik)" ' Ende Diagramm hinzufügen und Typ festlegen ' Datenreihen zufügen, ausrichten und benennen: ActiveChart.Axes(xlValue).MinimumScale = 0 ActiveChart.SetSourceData Source:=Sheets("Tabelle1").Range( _ Adresse2), PlotBy:=xlRows ActiveChart.SeriesCollection(2).Name = A ActiveChart.SeriesCollection(1).Name = "=""Prod. Mio. m²""" ' Ende Datenreihen zufügen, ausrichten und benennen ' Trendlinie hinzufügen: ActiveChart.SeriesCollection(2).Select ' ActiveChart.SeriesCollection(2).Trendlines.Add(Type:=xlPolynomial, Order:=2, Forward:=0, _ ' Backward:=0, DisplayEquation:=False, DisplayRSquared:=False).Select ActiveChart.SeriesCollection(2).Trendlines.Add(Type:=xlLinear, Forward:=0, _ Backward:=0, DisplayEquation:=False, DisplayRSquared:=False).Select ActiveChart.SeriesCollection(2).Trendlines(1).Name = "Trend Preis/1.000m²" ' Ende Trendlinie hinzufügen ' Gitternetzlinien zufügen: With ActiveChart.Axes(xlCategory) .HasMajorGridlines = True .HasMinorGridlines = False End With With ActiveChart.Axes(xlValue) .HasMajorGridlines = True .HasMinorGridlines = False End With ' Ende Gitternetzlinien zufügen ' Legende und Datentabelle: ActiveChart.HasLegend = True ActiveChart.Legend.Select Selection.Position = xlBottom ActiveChart.HasDataTable = False ' Ende Legende und Datentabelle ' Chartlinien formatieren: ActiveChart.SeriesCollection(1).Select With Selection.Border .ColorIndex = 3 .Weight = xlMedium .LineStyle = xlContinuous End With With Selection .MarkerBackgroundColorIndex = xlNone .MarkerForegroundColorIndex = xlNone .MarkerStyle = xlNone .Smooth = False .MarkerSize = 3 .Shadow = False .AxisGroup = 2 End With ActiveChart.SeriesCollection(2).Select With Selection.Border .ColorIndex = 6 .Weight = xlMedium .LineStyle = xlContinuous End With With Selection .MarkerBackgroundColorIndex = xlNone .MarkerForegroundColorIndex = xlNone .MarkerStyle = xlNone .Smooth = False .MarkerSize = 3 .Shadow = False .AxisGroup = 1 End With ' Ende Chartlinien formatieren ' Diagramm auf Bildschirm ausrichten: ActiveChart.ChartArea.Select Gname = Mid(ActiveChart.Name, 24, 125) ActiveSheet.Shapes(Gname).ScaleWidth 1.29, msoFalse, _ msoScaleFromTopLeft ActiveSheet.Shapes(Gname).ScaleHeight 0.9, msoFalse, _ msoScaleFromTopLeft ActiveSheet.Shapes(Gname).IncrementLeft 67 ActiveSheet.Shapes(Gname).IncrementTop 160 ' Ende Diagramm auf Bildschirm ausrichten ' Legende formatieren ActiveSheet.ChartObjects(Gname).Activate ActiveChart.Legend.Select With Selection.Border .Weight = xlHairline .LineStyle = xlAutomatic End With Selection.Shadow = True With Selection.Interior .ColorIndex = 15 .PatternColorIndex = 1 .Pattern = xlSolid End With Selection.AutoScaleFont = True With Selection.Font .Name = "Arial" .FontStyle = "Fett" .Size = 10 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic .Background = xlAutomatic End With ' Ende Legende formatieren ' Ende Erklärung für Trendlinie zufügen ActiveChart.Shapes.AddTextbox(msoTextOrientationHorizontal, 144#, 0#, _ 181.5, 14.25).Select Selection.Characters.Text = "Trendlinie = Linear" Selection.AutoScaleFont = False With Selection.Characters(Start:=1, Length:=19).Font .Name = "Arial" .FontStyle = "Standard" .Size = 9 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlTop .Orientation = xlHorizontal .AutoSize = False End With ' Ende Erklärung für Trendlinie zufügen Windows("Analyse HiBe-2009.xls").Activate B.Select ActiveSheet.CommandButton2.Enabled = True Application.ScreenUpdating = True Exit Sub Abbruch: Select Case Err.Number ' Fehlernummer auswerten. Case 1004 ' Fehler "Material nicht benutzt" MsgBox ("Dieses Jahr wurde kein(e) " & A & " verbraucht") ' vorhandene Diagramme löschen: Application.ActiveSheet.ChartObjects.Delete ' Ende vorhandene Diagramme löschen Case Else ' Andere Fälle hier bearbeiten... End Select ' Resume ' Ausführung in der Zeile ' fortsetzen, die den Fehler End Sub
Private Sub CommandButton2_Click() ' (06.10.2009) hier die überarbeitete Formatierung der Trandlinien ' und der Text Boxen in den Charts - jetzt komplett ohne "Select" ' und ohne "Activate". ' Es geht um das Umschalten der Trendlinien von Linear zu Polynomisch ' und umgekehrt - jeweils abhängig von der aktuell angezeigten Variante. ' Gleichzeitig wird in der Text Box die jeweilige Linienart benannt. ' Das sieht doch schon besser aus: Dim Dia1 As Object Dim Dia2 As Object Dim B As Range Dim Text(1) As String If ActiveSheet.ChartObjects.Count <> 2 Then Exit Sub Set B = ActiveCell Set Dia1 = ActiveSheet.ChartObjects(1).Chart Set Dia2 = ActiveSheet.ChartObjects(2).Chart Text(0) = "Trendlinie = Linear" Text(1) = "Trendlinie = Polynomisch 2. Ordnung" With Dia1.SeriesCollection(1).Trendlines(1) If .Type = xlLinear Then .Type = xlPolynomial .Order = 2 Dia1.Shapes("Text Box 1").TextFrame.Characters.Text = Text(1) Else .Type = xlLinear Dia1.Shapes("Text Box 1").TextFrame.Characters.Text = Text(0) End If End With With Dia2.SeriesCollection(2).Trendlines(1) If .Type = xlLinear Then .Type = xlPolynomial .Order = 2 Dia2.Shapes("Text Box 1").TextFrame.Characters.Text = Text(1) Else .Type = xlLinear Dia2.Shapes("Text Box 1").TextFrame.Characters.Text = Text(0) End If End With End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) ' Steht die Markierung im Blatt auf einem "chartfähigen" Datensatz, ' werden die CommandButtons dahin verfrachtet. Nämlich immer dann, ' wenn in der aktiven Zeile in Spalte "A" eine Materialnummer (oder ' ein Dummy für die Summenzeilen) vorhanden ist. ' Steht die Markierung im Blatt NICHT auf einem "chartfähigen" Datensatz, ' wird ausserdem der CommadButton für das Erstellen der Cahrts deaktiviert: If Not IsEmpty(Range("A" & Selection.Row)) Then CommandButton1.Top = ActiveCell.Offset(0, 0).Top CommandButton1.Enabled = True CommandButton2.Top = ActiveCell.Offset(2, 0).Top Else CommandButton1.Enabled = False End If ' ****************************************************************** ' wenn nicht 2 Charts im Blatt vorhanden sind, dann macht es auch ' keinen Sinn, den Trendlinien-Umschalt-Button aktiv zu halten. Dann ' wird er deaktiviert. Sobald alle Charts erstellt sind, kann der ' Button wieder aktiviert werden. Also: If ChartObjects.Count <> 2 Then CommandButton2.Enabled = False Else CommandButton2.Enabled = True End If End Sub
