Option Explicit
Private Sub CommandButton1_Click()
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
' 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
A = ActiveCell.Value
X = ActiveCell.Row
Set Analyse = Sheets("Analyse Hiebe (Grafik)")
Set Daten = Sheets("Tabelle1")
C = "Ø Preis/" & Daten.Cells(X, 2).Offset(128, 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 + 64, 3), Cells(X + 64, 14))
Set Datenreihe(3) = Sheets(1).Range(Cells(X + 128, 3), Cells(X + 128, 14))
Set Datenreihe(4) = Sheets(1).Range(Cells(X + 198, 3), Cells(X + 198, 14))
Set Datenreihe(5) = Sheets(1).Range(Cells(196, 3), Cells(196, 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
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:=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 -105
' 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
Windows("Analyse HiBe.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:=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, 100)
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 125
' 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
Windows("Analyse HiBe.xls").Activate
B.Select
Application.ScreenUpdating = True
End Sub
Beispiel 2
nach oben
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Dim ACR, ACC As Integer
ACR = ActiveCell.Row
ACC = ActiveCell.Column
' gerade ist mir noch eingefallen, dass man
' hier auch mit "Intersect" arbeiten könnte...zu spät..
With ActiveSheet.CommandButton1
If ACC = 2 And ( _
ACR = 3 _
Or (ACR >= 6 And ACR <= 13) _
Or (ACR >= 16 And ACR <= 52) _
Or (ACR >= 54 And ACR <= 57) _
Or (ACR >= 59 And ACR <= 60)) _
Or ACR = 62 Then
.Top = ActiveCell.Offset(0, 0).Top
.Enabled = True
Else
.Top = ActiveCell.Offset(0, 0).Top
.Enabled = False
End If
End With
End Sub