AW: If Abhängig Makro ausführen
04.08.2017 13:16:38
fcs
Hallo Martin,
wenn die Werte aus den beiden Berichtsformen überlagert werden sollen, dannn muss die Struktur der Makros komplett umgestrickt werden.
Außer den Makros zur Drop-Down-Aktualisierung ist alles geändert.
Gruß
Franz
Option Explicit
Dim blnAusfuehren As Boolean '###Deklaration### Boolean ist true oder false Datentyp
Dim lngLetzte As Long 'Long hat 4 Bytes
Sub DiaAktualisieren(ByVal strTabelle As String)
Dim objChart As ChartObject
Dim strTypBericht As String
Dim lngReihen As Long
'Alle Datereihen in den Diagrammen löschen
For Each objChart In ActiveSheet.ChartObjects
With objChart.Chart
For lngReihen = .SeriesCollection.Count To 1 Step -1
objChart.Chart.SeriesCollection(lngReihen).Delete
Next lngReihen
End With
Next
'in Spalte D ausgewählte Tabellenblätter ab Zeile 4 abarbeiten
lngReihen = 4
Do
If Cells(lngReihen, 4) = "" Then Exit Do 'keine weiteren Tabellen vorhanden
strTabelle = Cells(lngReihen, 4).Value
'Name Tabellenblatt prüfen
Select Case strTabelle
Case "Tab AXYZ", "Tab ABCZ"
'Falls eine Auswahl getroffen ist _
aber kein Diagramm gezeigt werden soll können hier Blattnamen stehen
Case Else
strTypBericht = Worksheets(strTabelle).Range("A1").Text
'Typ des Berichtes Vergleichen
Select Case strTypBericht
Case "Prüfbericht Luftleistung"
Call Dia_Luftleistung(strTabelle:=strTabelle)
Case "Prüfbericht Druckwiderstand"
Call Dia_Druckwiderstand(strTabelle:=strTabelle)
Case "" 'Blatt "keine Auswahl"
'do nothing
Case Else
MsgBox "für Berichtsart """ & strTypBericht _
& """ gibt es keine Diagrammdarstellung!" _
& vbLf & vbLf _
& "ggf. zusätzliche Case-Anweisung im Makro einfügen.", _
vbOKOnly, "Anpaasen Daten Diagramm"
End Select
End Select
lngReihen = lngReihen + 1
Loop
End Sub
Sub Dia_Luftleistung(ByVal strTabelle As String)
Dim objChart As ChartObject
For Each objChart In ActiveSheet.ChartObjects
Select Case objChart.Name 'In Anführungszeichen steht der Namme des Diagramm
'strBereichY_Werte definiert hierzu die y-Werte
'strBereichX_Werte definiert hierzu die Werte der X-Achse
Case "FCD"
Call Dia_Datenzuweisen(objChart.Chart, strTabelle, _
strBereichY_Werte:="E8:E32", _
strBereichX_Werte:="F8:F32")
Case "FDE"
Call Dia_Datenzuweisen(objChart.Chart, strTabelle, _
strBereichY_Werte:="H8:H32", _
strBereichX_Werte:="F8:F32")
Case "Leistung"
Call Dia_Datenzuweisen(objChart.Chart, strTabelle, _
strBereichY_Werte:="G8:G32", _
strBereichX_Werte:="F8:F32")
Case "Arbeitspunkt"
Call Dia_Datenzuweisen(objChart.Chart, strTabelle, _
strBereichY_Werte:="J8:J32", _
strBereichX_Werte:="F8:F32")
End Select
Next objChart
End Sub
Sub Dia_Druckwiderstand(ByVal strTabelle As String)
Dim objChart As ChartObject
For Each objChart In ActiveSheet.ChartObjects
Select Case objChart.Name 'In Anführungszeichen steht der Namme des Diagramm
'strBereichY_Werte definiert hierzu die y-Werte
'strBereichX_Werte definiert hierzu die Werte der X-Achse
Case "FCD"
Call Dia_Datenzuweisen(objChart.Chart, strTabelle, _
strBereichY_Werte:="F15:F29", _
strBereichX_Werte:="E15:E29")
Case "FDE", "Leistung", "Arbeitspunkt"
End Select
Next objChart
End Sub
Sub Dia_Datenzuweisen(objChart As Chart, ByVal strTabelle, _
ByVal strBereichY_Werte As String, _
ByVal strBereichX_Werte As String)
With objChart
'Datenreihe mit Daten aus Blatt erstellen
With .SeriesCollection.NewSeries
.XValues = Worksheets(strTabelle).Range(strBereichX_Werte)
.Values = Worksheets(strTabelle).Range(strBereichY_Werte)
If strTabelle = "keine Auswahl" Then
.Name = ""
Else
.Name = strTabelle
End If
End With
End With
End Sub
'#### Ereigbis-Makros ####
Private Sub DropDown_aktualisieren()
Dim RNG As Range, WS, Z, strFilter As String
On Error GoTo Fehler
Set RNG = Range("D4:D360")
Me.Unprotect
Application.EnableEvents = False
strFilter = ""
For Each WS In ActiveWorkbook.Sheets
Select Case WS.Name
Case Me.Name, "Listenfeed"
'Diese Blätter nicht ins DropDown
Case Me.Name, "Übersicht"
Case Else
If Application.WorksheetFunction.CountIf(RNG, WS.Name) = 0 Then
strFilter = strFilter & WS.Name & ","
End If
End Select
Next
If strFilter "" Then
With RNG.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=strFilter
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
Else 'Es sind bereits alle Produkte ausgewählt
With RNG.Validation
.Delete
End With
MsgBox "Es sind bereits alle Produkte ausgewählt"
End If
Fehler:
If Err.Number 0 Then MsgBox "Fehler: " & _
Err.Number & vbLf & Err.Description: Err.Clear
Me.Protect
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Activate() 'Immer wenn das Arbeitsblatt ausgewählt wird, _
wird auch die Dropdown Liste aktualisiert
Call DropDown_aktualisieren
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Weiter
lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 4)), _
Cells(Rows.Count, 4).End(xlUp).Row, Rows.Count)
If blnAusfuehren = False Then
Me.Unprotect 'Blattschutz aufheben
Application.EnableEvents = False
If Not Intersect(Target, Columns(4).SpecialCells(xlCellTypeAllValidation)) _
Is Nothing Then
If Target.Cells.Count = 1 Then
Call DiaAktualisieren(strTabelle:=Target.Text)
End If
End If
Weiter: 'hier weiter, wenn bereits alle Blätter im Diagramm angezeigt werden.
Me.Protect 'Blattschutz setzen
Application.EnableEvents = True
Call DropDown_aktualisieren
End If
If Not Intersect(Target, Range("D4:D300")) Is Nothing Then
If Target.Range("A1").Value "" And Target.Cells.Count = 1 Then '