Option Explicit
Const c_mappe_Auwswertung = Auswertung.xls
Const c_blt_Cockpit = Cockpit
Const c_blt_Auswertung = Auswertung_
'Parameter für Diagramme
Const c_DiagLinie3_Range = A44:D44
Const c_DiagLinie3_ErsteZeile = 2
Const c_DiagLinie3_LinkeSpalte = 1
Const c_DiagLinie3_HoeheInZeilen = 10
Const c_DiagLinie3_BreiteInSpalten = 10
Const c_DiagLinie3_AddUeberschrift = Säulendiagramm - Gesamt
Const c_DiagLinie1_Range = A46:B52
Const c_DiagLinie1_ErsteZeile = c_DiagLinie3_ErsteZeile + c_DiagLinie3_HoeheInZeilen
Const c_DiagLinie1_LinkeSpalte = 1
Const c_DiagLinie1_HoeheInZeilen = 10
Const c_DiagLinie1_BreiteInSpalten = 6
Const c_DiagLinie1_AddUeberschrift = Liniendiagramm 1
Const c_DiagLinie2_Range = A53:B55
Const c_DiagLinie2_ErsteZeile = c_DiagLinie3_ErsteZeile + c_DiagLinie3_HoeheInZeilen
Const c_DiagLinie2_LinkeSpalte = c_DiagLinie1_LinkeSpalte + c_DiagLinie1_BreiteInSpalten
Const c_DiagLinie2_HoeheInZeilen = 10
Const c_DiagLinie2_BreiteInSpalten = 4
Const c_DiagLinie2_AddUeberschrift = Liniendiagramm 2
Sub CockpitZusammenstellen()
Dim wb As Workbook, wsc As Worksheet, wsa As Worksheet
Dim f_Ausw() As String, f_Ausw_cnt As Long
Dim s_tmp As String, x As Long, y As Long
Dim l_zeile As Long
->Auswertungs-Mappe aktivieren
On Error Resume Next
Workbooks(c_mappe_Auwswertung).Activate
If Err.Number <> 0 Then
Err.Clear
MsgBox (Bitte öffnen Sie & c_mappe_Auwswertung)
GoTo Aufraeumen
End If
On Error GoTo 0
Set wb = ActiveWorkbook
->Blatt Cockpit neu erzeugen
Set wsc = wb.Worksheets.Add(Before:=Worksheets(1))
wsc.Name = c_blt_Cockpit & Format(Now(), _yyyymmdd_hhnn)
->schauen, welche Auswertungsblätter vorhanden sind
ReDim f_Ausw(1 To 1): f_Ausw_cnt = 0
For Each wsa In wb.Worksheets
If Left(wsa.Name, Len(c_blt_Auswertung)) = c_blt_Auswertung Then
f_Ausw_cnt = f_Ausw_cnt + 1
ReDim Preserve f_Ausw(1 To f_Ausw_cnt)
f_Ausw(f_Ausw_cnt) = wsa.Name
End If
Next
If f_Ausw_cnt = 0 Then
MsgBox (keine Auswertungsblätter vorhanden)
End If
->Namen Auswertungsblätter sortieren
For x = 1 To f_Ausw_cnt - 1
For y = x + 1 To f_Ausw_cnt
If f_Ausw(x) > f_Ausw(y) Then s_tmp = f_Ausw(x): f_Ausw(x) = f_Ausw(y): f_Ausw(y) = s_tmp
Next
Next
->Liniendiagramm 1 ins Cockpit
->Anfangszeile Diagramm setzen
l_zeile = c_DiagLinie1_ErsteZeile
For x = 1 To f_Ausw_cnt
Call LinienChartErstellen(l_zeile, wsc, f_Ausw(x), _
c_DiagLinie1_Range, _
c_DiagLinie1_LinkeSpalte, _
c_DiagLinie1_HoeheInZeilen, _
c_DiagLinie1_BreiteInSpalten, _
c_DiagLinie1_AddUeberschrift)
Next
->Liniendiagramm 2 ins Cockpit
->Anfangszeile Diagramme setzen
l_zeile = c_DiagLinie2_ErsteZeile
For x = 1 To f_Ausw_cnt
Call LinienChartErstellen(l_zeile, wsc, f_Ausw(x), _
c_DiagLinie2_Range, _
c_DiagLinie2_LinkeSpalte, _
c_DiagLinie2_HoeheInZeilen, _
c_DiagLinie2_BreiteInSpalten, _
c_DiagLinie2_AddUeberschrift)
Next
->Säulendiagramm 3 ins Cockpit
->Anfangszeile Diagramm setzen
l_zeile = c_DiagLinie3_ErsteZeile
Call SaeulenChartErstellen(l_zeile, wsc, wb, f_Ausw(), f_Ausw_cnt, _
c_DiagLinie3_Range, _
c_DiagLinie3_LinkeSpalte, _
c_DiagLinie3_HoeheInZeilen, _
c_DiagLinie3_BreiteInSpalten, _
c_DiagLinie3_AddUeberschrift)
->Seitenformat - auf
With wsc.PageSetup
.Orientation = xlLandscape
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 32
End With
wsc.Cells(1, 1).Select
Aufraeumen:
Set wb = Nothing: Set wsc = Nothing: Set wsa = Nothing
End Sub
Sub LinienChartErstellen(l_zeile As Long, _
wsc As Worksheet, _
s_blt As String, _
s_Range As String, _
l_linkeSpalte As Long, _
l_HoeheInZeilen As Long, _
l_BreiteInSpalten As Long, _
s_AddTextUberschrift As String)
Dim ch As Chart, cho As ChartObject, sh As Shape
->Chart erzeugen
Set ch = Charts.Add
With ch
.ChartType = xlLineMarkers
.SetSourceData _
Source:=Sheets(s_blt).Range(s_Range), _
PlotBy:=xlColumns
.HasTitle = True
.ChartTitle.Text = s_blt & - & s_AddTextUberschrift
.Axes(xlCategory, xlPrimary).HasTitle = False
.Axes(xlValue, xlPrimary).HasTitle = False
End With
ch.Location Where:=xlLocationAsObject, _
Name:=wsc.Name
->Position des Charts setzen
Set cho = wsc.ChartObjects(wsc.ChartObjects.Count)
With cho
.Left = wsc.Cells(l_zeile, l_linkeSpalte).Left
.Top = wsc.Cells(l_zeile, l_linkeSpalte).Top
.Width = wsc.Cells(l_zeile, l_linkeSpalte + l_BreiteInSpalten).Left - _
wsc.Cells(l_zeile, l_linkeSpalte).Left
.Height = wsc.Cells(l_zeile + l_HoeheInZeilen, l_linkeSpalte).Top - _
wsc.Cells(l_zeile, l_linkeSpalte).Top
End With
->nächste freie Zeile setzen
l_zeile = l_zeile + l_HoeheInZeilen
->aufräumen
Set cho = Nothing: Set ch = Nothing: Set sh = Nothing
End Sub
Sub SaeulenChartErstellen(l_zeile As Long, _
wsc As Worksheet, _
wb As Workbook, _
f_Ausw() As String, _
f_Ausw_cnt As Long, _
s_Range As String, _
l_linkeSpalte As Long, _
l_HoeheInZeilen As Long, _
l_BreiteInSpalten As Long, _
s_AddTextUberschrift As String)
Dim ch As Chart, cho As ChartObject, sh As Shape
Dim r As Range, l_z As Long, l_c As Long, x As Long
->Zeilen zusammenkopieren
l_z = l_zeile - 1
For x = 1 To f_Ausw_cnt
l_z = l_z + 1
wb.Worksheets(f_Ausw(x)).Range(s_Range).Copy
wsc.Cells(l_z, 1).Select
wsc.Paste link:=True
Next
l_c = wb.Worksheets(f_Ausw(1)).Range(s_Range).Columns.Count
Set r = wsc.Range(Cells(l_zeile, 1), Cells(l_z, l_c))
->Chart erzeugen
Set ch = Charts.Add
With ch
.ChartType = xlColumnClustered
.SetSourceData _
Source:=r, _
PlotBy:=xlColumns
.HasTitle = True
.ChartTitle.Text = s_AddTextUberschrift
.Axes(xlCategory, xlPrimary).HasTitle = False
.Axes(xlValue, xlPrimary).HasTitle = False
End With
ch.Location Where:=xlLocationAsObject, _
Name:=wsc.Name
->Position des Charts setzen
Set cho = wsc.ChartObjects(wsc.ChartObjects.Count)
With cho
.Left = wsc.Cells(l_zeile, l_linkeSpalte).Left
.Top = wsc.Cells(l_zeile, l_linkeSpalte).Top
.Width = wsc.Cells(l_zeile, l_linkeSpalte + l_BreiteInSpalten).Left - _
wsc.Cells(l_zeile, l_linkeSpalte).Left
.Height = wsc.Cells(l_zeile + l_HoeheInZeilen, l_linkeSpalte).Top - _
wsc.Cells(l_zeile, l_linkeSpalte).Top
End With
->nächste freie Zeile setzen
l_zeile = l_zeile + l_HoeheInZeilen
->aufräumen
Set cho = Nothing: Set ch = Nothing: Set sh = Nothing: Set r = Nothing
End Sub
