Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1608to1612
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

für Zeitdiagramm richtige Daten raussuchen

für Zeitdiagramm richtige Daten raussuchen
19.02.2018 09:20:44
Burak
Guten Morgen,
also ich habe in einem Tabellenblatt Daten.
in Zelle A2 steht R1, dann kommen einige Datensätze, dann direkt im Anschluss steht in Zelle A80 R2, dann wieder Datensätze usw, bis R5 und dann Datensätze.
Dann habe ich auf einem anderen Tabellenblatt eine Schaltfläche, die das Makro starten soll und ein drittes Blatt, wo die Grafik eingefügt wird.
Das Makro fragt erst ab, welche Linie (R1, R2,... R5) man haben möchte und welchen Barcode, das Makro sucht in dem einen Tabellenblatt die Zelle wo die Linienbezeichnung (R1...) steht, und beachtet darunter die Datensätze bis die nächste Linienbezeichnung steht.
In diesen Datensätzen steht in Spalte A Barcodes, in Spalte M ein Datum bzw. mehrere und in Spalte N die Uhrzeit.
Was ich jetzt möchte ist, dass wenn der Benutzer z.B. für die Linie "R3" eingibt und als Barcode "1270", soll er ein Zeitverlaufsdiagramm anhand Spalte M und N für die Datensätze machen die zwischen R3 und R4 stehen, den gesuchten Barcode
beinhalten.
Beispieldatei ohne Makros:
https://www.herber.de/bbs/user/119900.xlsx
Also letzten Endes glaube ich mit Vlookup, copy, und addchart sollte das machbar sein.
Kann mir da jmd etwas aushelfen?
Freundliche Grüße

13
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Nachtrag
19.02.2018 11:26:20
Burak
Nachtrag: Also Spalte M und N dienen als Werte für die x-Achse und Spalte E sind die Werte die im Diagramm über den Zeitverlauf angezeigt werden sollen.
AW: Nachtrag
19.02.2018 17:17:47
UweD
Hallo
versuch das mal
https://www.herber.de/bbs/user/119916.xlsm
Anderungen in den blauen Zellen lösen das makro aus
enthaltener Code
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error GoTo Fehler
    If Not Intersect(Range("B2"), Target) Is Nothing Then
        Dim Tb1, Tbtmp, EZ As Integer
        Set Tb1 = Sheets("Import starten")
        Set Tbtmp = Sheets("TMP")
        Dim LR1 As Double, LR2 As Double
        EZ = 10
        
        With Tbtmp
            LR1 = .Cells(.Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte 
            .Cells.ClearContents
            Sheets("Mikrostörungen - Daten").Columns(1).Copy Tbtmp.Columns(1)
            .Cells(1, 2) = 0
            .Cells(1, 3) = "Bis"
            
            LR1 = .Cells(.Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte 
            
            With .Cells(2, 2).Resize(LR1 - 1)
                .FormulaR1C1 = "=IF(ISNUMBER(FIND(""Linie"",RC[-1])),ROW()+1,0)"
                .Value = .Value
            End With
            
            .Range("$A:$C").RemoveDuplicates Columns:=2, Header:=xlNo
            
            LR2 = .Cells(.Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte 
            
            With .Cells(2, 3).Resize(LR2 - 2)
                .FormulaR1C1 = "=R[1]C[-1]-2"
                .Value = .Value
            End With
            .Cells(LR2, 3) = LR1
           
           
            With Target.Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
                    Operator:=xlBetween, Formula1:="=TMP!$A$2:$A$" & LR2
            End With
            
            Application.EnableEvents = False
            Range("B4").ClearContents
            Call Resetten(Tb1, EZ + 1, LR1)
            Application.EnableEvents = True

        End With
    End If
    '*** Fehlerbehandlung 
    Err.Clear
Fehler:
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Tb1, Tb2, Tb3, Tbtmp, LR1 As Double, LR2 As Double, EZ As Integer
    Dim Von As Double, Bis As Double
    Dim MMax As Date, MMin As Date
    
    Set Tb1 = Sheets("Import starten")
    Set Tb2 = Sheets("Mikrostörungen - Daten")
    Set Tb3 = Sheets("Linienauswertung - Grafiken")
    Set Tbtmp = Sheets("TMP")
    EZ = 10
    
    If Not Intersect(Range("B2"), Target) Is Nothing Then
    
        With Tbtmp
            Von = .Cells(WorksheetFunction.Match(Target, .Columns(1), 0), 2)
            Bis = .Cells(WorksheetFunction.Match(Target, .Columns(1), 0), 3)
            
            Tb2.Range(Tb2.Cells(Von, 2), Tb2.Cells(Bis, 2)).Copy _
                Tbtmp.Cells(2, 5)
            
            .Cells(1, 5) = "Codes von " & Target
            .Columns(5).RemoveDuplicates Columns:=1, Header:=xlNo
            
            LR2 = .Cells(.Rows.Count, "E").End(xlUp).Row
        
        End With

        With Tb1.Range("B4").Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
                Operator:=xlBetween, Formula1:="=TMP!$E$2:$E$" & LR2
        End With
        
        LR1 = Tb1.Cells.SpecialCells(xlCellTypeLastCell).Row 'Letzte Zeile des gesamten Blattes 
        
        Application.EnableEvents = False
        Call Resetten(Tb1, EZ + 1, LR1)
        Application.EnableEvents = True
    End If

    
    If Not Intersect(Range("B4"), Target) Is Nothing Then
    
        EZ = 10 'Überschrift 
        LR1 = Tb1.Cells.SpecialCells(xlCellTypeLastCell).Row 'Letzte Zeile des gesamten Blattes 
        
        Application.EnableEvents = False
        Call Resetten(Tb1, EZ + 1, LR1)
        Application.EnableEvents = True
        
        Von = Tbtmp.Cells(WorksheetFunction.Match(Tb1.Range("B2"), Tbtmp.Columns(1), 0), 2)
        Bis = Tbtmp.Cells(WorksheetFunction.Match(Tb1.Range("B2"), Tbtmp.Columns(1), 0), 3)
    
        With Tb2
            If .AutoFilterMode Then .AutoFilterMode = False ' Autofilter ausschalten 
            .Cells(Von - 1, 2) = "Code"
            .Range(.Cells(Von - 1, 2), .Cells(Bis, 2)).AutoFilter Field:=1, _
                Criteria1:=Target
            
            Application.EnableEvents = False
            .Rows(Von & ":" & Bis).Copy Tb1.Rows(11)
            
            LR1 = Tb1.Cells(Tb1.Rows.Count, "B").End(xlUp).Row
            If LR1 > EZ Then
                With Tb1.Cells(11, 15).Resize(LR1 - EZ)
                    .FormulaR1C1 = "=RC[-2]+RC[-1]"
                    .NumberFormat = "DD.MM.YYYY hh:mm:ss"
                End With
            End If
            Application.EnableEvents = True
    
            .AutoFilterMode = False
            .Cells(Von - 1, 2).ClearContents
        End With
        Application.ScreenUpdating = False

        With Tb3.ChartObjects("Diagramm 1").Chart
            .FullSeriesCollection(1).XValues = "='Import starten'!$O$11:$O$" & LR1
            .FullSeriesCollection(1).Values = "='Import starten'!$E$11:$E$" & LR1
            .FullSeriesCollection(1).Name = Range("E10") & ": " & Range("B2") & " / Code: " & Target
            
            MMin = WorksheetFunction.Min(Tb1.Range("$O$11:$O$" & LR1))
            MMax = WorksheetFunction.Max(Tb1.Range("$O$11:$O$" & LR1))
            
'            .Axes(xlCategory).MinimumScale = MMin 
'            .Axes(xlCategory).MaximumScale = MMax 
'            .Axes(xlCategory).MajorUnit = MMax - MMin + 1 
        End With
        
        
    End If
    '*** Fehlerbehandlung 
    Err.Clear
Fehler:
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear
End Sub

Private Sub Resetten(TB, E1, LR)
        TB.Rows(E1).Resize(LR - E1 + 1).ClearContents
End Sub


LG UweD
Anzeige
AW: Nachtrag
20.02.2018 06:18:27
Burak
Guten Morgen und danke erstmal,
folgender Fehler tritt auf, egal welche Linien und Code-Kombination ich auswähle aus der ComboBox:
laufzeitfehler 438
Objekt unterstützt die Eigenschaft dieser Methode nicht!
Folgende Zeile markiert:
With Tb3.ChartObjects("Diagramm 1").Chart
.FullSeriesCollection(1).XValues = "='Import starten'!$O$11:$O$" & LR1
Grüße
AW: Intermezzo: Die Objekt-Klasse gibt's....
20.02.2018 06:30:51
Mullit
...in VBA erst ab xl2013....
Gruß, Mullit
AW: Die Objekt-Klasse FullSeriesCollection....
20.02.2018 06:37:44
Mullit
...war hier gemeint, da müsstest Du also den Code anpassen...:-(
Gruß, Mullit
AW: Die Objekt-Klasse FullSeriesCollection....
20.02.2018 06:43:13
Mullit
...könnte allerdings identisch sein mit dem .SeriesCollection-Objekt, mußt Du mal testen...;-)
Gruß, Mullit
Anzeige
AW: Die Objekt-Klasse FullSeriesCollection....
20.02.2018 06:56:58
Burak
ja mit SeriesCollection funktioniert es scheinbar, nur ist der Zeitrahmen des Diagramms etwas ... sagen wir utopisch. Die Daten befinden sich in einem Zeitraum von etwa 2 Monaten und das Diagramm geht vom Jahr 1900 bis 2036.
AW: Die Objekt-Klasse FullSeriesCollection....
20.02.2018 08:31:43
UweD
Hallo
- bei den Musterdaten habe ich maximal mal 4 Einträge zu einem Code vorgefunden
- und die hatten den gleichen Zeitstempel
= Um das Darzustellen (und das bei automatischen Einstellungen der X-Achse) gibt das wenig Sinnvolles
- Ich hatte noch rumgespielt, aber nichts Vernünftigeres dargestellt bekommen.
'            MMin = WorksheetFunction.Min(Tb1.Range("$O$11:$O$" & LR1)) 
'            MMax = WorksheetFunction.Max(Tb1.Range("$O$11:$O$" & LR1)) 
' 
'            .Axes(xlCategory).MinimumScale = MMin 
'            .Axes(xlCategory).MaximumScale = MMax 
'            .Axes(xlCategory).MajorUnit = MMax - MMin + 1 

- Das ist aber dann Chart Sache und hat nichts mit dem Makro zu tun.


Bau doch mal ein Diagramm so zusammen, wie du es dir vorstellst, dann kann der Datenbereich dann zugewiesen werden.
LG UweD
Anzeige
AW: Die Objekt-Klasse FullSeriesCollection....
20.02.2018 08:58:57
Burak
ah ich sehe schon da waren noch die Apostroph vorgestellt, jetzt geht es mit dem Bereich.
Nur noch eine Sache ist nich so wie ich es mir vorgestellt habe. Habe an deinem Code bissel versucht was zu ändern aber habe es nicht hinbekommen.
Bei diesem Makro wählt man einen gesamten 10-stelligen Barcode aus Spalte B.
Die Auswahl soll aber der 4-stellige Barcode aus Spalte A erfolgen, also z.B Linie R1 (wie gehabt) und dann 3026 als Barcode, 1270, oder 4350.
Da ich einige Tage brauchen werde, bis ich dein Code komplett verstanden habe, kannst du mir da vllt aushelfen :D
AW: Die Objekt-Klasse FullSeriesCollection....
20.02.2018 11:36:16
UweD
Hallo nochmal
https://www.herber.de/bbs/user/119931.xlsm
ich hab es jetzt variabel gehalten.
Ausserdem einigermassen kommentiert.
der enthaltene Code
in einem Modul:
Option Explicit
Option Private Module

'*** Konstante zur gemeinsamen Nutzung deklinieren 

Public Const EZ As Integer = 10 'Erste Zeile 
Public Const SSpalte1 As Integer = 1 'Suchspalte 1 für Linien 
Public Const SSpalte2 As Integer = 1 'Suchspalte 2 für Codes 
Public Const ZSpalte As Integer = 1

'*** Variable zur gemeinsamen Nutzung deklinieren 

Public WB1, TB1, TB2, TB3, TBTmp
Public LR1 As Double, LR2 As Double
Public EingabeLinie As Range, EingabeCodes As Range
Public Von As Double, Bis As Double
Public MMax As Date, MMin As Date


Public Belegt As Boolean 'Set nur 1x ausführen 

Public Sub Var_Bel()
    'Zuweisen von Objekten nur 1x 
    
    If Belegt = False Then
        Set WB1 = ThisWorkbook
        Set TB1 = WB1.Sheets("Import starten")
        Set TB2 = WB1.Sheets("Mikrostörungen - Daten")
        Set TB3 = WB1.Sheets("Linienauswertung - Grafiken")
        
        Set TBTmp = WB1.Sheets("TMP") 'Temporäres Blatt 

        Set EingabeLinie = TB1.Range("B2") 'Eingabefeld für Linie 
        Set EingabeCodes = TB1.Range("B4")  'Eingabefeld für Codes 

'*** 
        Belegt = True
    End If
    
End Sub

Im Codebereich des Blattes:
Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error GoTo Fehler
    Call Var_Bel
    
    If Not Intersect(EingabeLinie, Target) Is Nothing Then
        With TBTmp
            LR1 = .Cells(.Rows.Count, SSpalte1).End(xlUp).Row 'letzte Zeile der Spalte 
            
            'Alle zellen löschen 
            .Cells.ClearContents
            
            'Erste Spalte in Temporäres Blatt kopieren 
            TB2.Columns(SSpalte1).Copy TBTmp.Columns(ZSpalte)
            
            'Überschriften setzten 
            .Cells(1, ZSpalte + 1) = 0 'wird für Duplikate benötigt 
            .Cells(1, ZSpalte + 2) = "Bis"
            
            LR1 = .Cells(.Rows.Count, ZSpalte).End(xlUp).Row 'letzte Zeile der Spalte 
            
            'Formel reinschreiben und in Werte verwandeln 
            'Wenn "Linie" dann Zeilennummer; sonst 0 
            With .Cells(2, ZSpalte + 1).Resize(LR1 - 1)
                .FormulaR1C1 = "=IF(ISNUMBER(FIND(""Linie"",RC[-1])),ROW()+1,0)"
                .Value = .Value
            End With
            
            'Duplikate entfernen / hier alle Nullen 
            .Columns(ZSpalte).Resize(, 3).RemoveDuplicates Columns:=2, Header:=xlNo
            
            LR2 = .Cells(.Rows.Count, ZSpalte).End(xlUp).Row 'letzte Zeile der Spalte 
            
            'Formeln "BIS" reinschreiben und durch Werte ersetzen 
            With .Cells(2, ZSpalte + 2).Resize(LR2 - 2)
                .FormulaR1C1 = "=R[1]C[-1]-2"
                .Value = .Value
            End With
            
            'Bei letzem "BIS" die letzte Zeile einsetzen 
            .Cells(LR2, ZSpalte + 2) = LR1
           
            'Gültigkeitsbereich für Linien neu ermitteln und festschreiben 
            WB1.Names("G_Linie").RefersTo = _
                 "=" & TBTmp.Name & "!" & Cells(2, ZSpalte).Address & ":" & Cells(LR2, ZSpalte).Address
            
            'Eingabe und Wertebereich löschen 
            Application.EnableEvents = False
            EingabeCodes.ClearContents
            Call Resetten(TB1, EZ + 1, LR1)
            Application.EnableEvents = True

        End With
    End If
    '*** Fehlerbehandlung 
    Err.Clear
Fehler:
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Call Var_Bel
    Application.ScreenUpdating = False
    
    If Not Intersect(EingabeLinie, Target) Is Nothing Then 'Nur bei Änderung der Linie 
    
        With TBTmp
            'Von Zeile und Bis Zeile füd die Linie ermitteln 
            Von = .Cells(WorksheetFunction.Match(Target, .Columns(ZSpalte), 0), 2)
            Bis = .Cells(WorksheetFunction.Match(Target, .Columns(ZSpalte), 0), 3)
            
            'Codezeilen für die ausgewählte Linie kopieren 
            TB2.Range(TB2.Cells(Von, SSpalte2), TB2.Cells(Bis, SSpalte2)).Copy _
                TBTmp.Cells(2, ZSpalte + 4)
            
            'Überschrift setzen 
            .Cells(1, ZSpalte + 4) = "Codes von " & Target
            
            'Duplikate entfernen 
            .Columns(ZSpalte + 4).RemoveDuplicates Columns:=1, Header:=xlNo
            
            LR2 = .Cells(.Rows.Count, ZSpalte + 4).End(xlUp).Row
        
        End With

        'Gültigkeitsbereich für Linien neu ermitteln und festschreiben 
        Application.EnableEvents = False
        WB1.Names("G_Codes").RefersTo = _
            "=" & TBTmp.Name & "!" & Cells(2, ZSpalte + 4).Address & ":" & Cells(LR2, ZSpalte + 4).Address
        
        LR1 = TB1.Cells.SpecialCells(xlCellTypeLastCell).Row 'Letzte Zeile des gesamten Blattes 
        
       'Wertebereich löschen 
        Call Resetten(TB1, EZ + 1, LR1)
    End If

    
    If Not Intersect(EingabeCodes, Target) Is Nothing Then ' Nur bei Änderungen der Codes 
    
        Application.EnableEvents = False
        LR1 = TB1.Cells.SpecialCells(xlCellTypeLastCell).Row 'Letzte Zeile des gesamten Blattes 
        
        'Wertebereich löschen 
        Call Resetten(TB1, EZ + 1, LR1)
        Application.EnableEvents = True
        
        'Von Zeile und Bis Zeile ermitteln 
        Von = TBTmp.Cells(WorksheetFunction.Match(TB1.Range("B2"), TBTmp.Columns(1), 0), 2)
        Bis = TBTmp.Cells(WorksheetFunction.Match(TB1.Range("B2"), TBTmp.Columns(1), 0), 3)
    
        With TB2
            'Autofilter ausschalten 
            If .AutoFilterMode Then .AutoFilterMode = False
            
            'Autofilter auf ausgewählten Code 
            .Range(.Cells(Von - 1, ZSpalte), .Cells(Bis, ZSpalte)).AutoFilter Field:=1, _
                Criteria1:=Target
            
            'gefilterten Bereich kopieren 
            Application.EnableEvents = False
            .Rows(Von & ":" & Bis).Copy TB1.Rows(EZ + 1)
            .AutoFilterMode = False
            
            LR1 = TB1.Cells(TB1.Rows.Count, "B").End(xlUp).Row
            'Zeitstempel aus Datum und Zeit addieren 
            If LR1 > EZ Then
                With TB1.Cells(11, 15).Resize(LR1 - EZ)
                    .FormulaR1C1 = "=RC[-2]+RC[-1]"
                    .NumberFormat = "DD.MM.YYYY hh:mm:ss"
                End With
            End If
            Application.EnableEvents = True
    
        End With

        'in bestehendem Chart den Datenbereich neu einstellen 
        With TB3.ChartObjects("Diagramm 1").Chart
            .SeriesCollection(1).XValues = "='" & TB1.Name & "'!$O$11:$O$" & LR1
            .SeriesCollection(1).Values = "='" & TB1.Name & "'!$E$11:$E$" & LR1
            .SeriesCollection(1).Name = Range("E10") & ": " & Range("B2") & " / Code: " & Target
            
            'x Achse anpassen 
            MMin = WorksheetFunction.Min(TB1.Range("$O$11:$O$" & LR1))
            MMax = WorksheetFunction.Max(TB1.Range("$O$11:$O$" & LR1))

            .Axes(xlCategory).MinimumScale = MMin
            .Axes(xlCategory).MaximumScale = MMax
            
            'Anzahl der xAchsenBeschriftungen anpassen (mit den 500 spielen) 
            .Axes(xlCategory).MajorUnit = (MMax - MMin + 1) / 500
            
            
            'Y Achse anpassen 
            MMin = WorksheetFunction.Min(TB1.Range("$E$11:$E$" & LR1))
            MMax = WorksheetFunction.Max(TB1.Range("$E$11:$E$" & LR1))
                        
            .Axes(xlValue).MinimumScale = MMin - 20
            .Axes(xlValue).MaximumScale = MMax + 20

        End With
        
        
    End If
    '*** Fehlerbehandlung 
    Err.Clear
Fehler:
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear
End Sub

Private Sub Resetten(TB, E1, LR)
        TB.Rows(E1).Resize(LR - E1 + 1).ClearContents
End Sub


LG UweD
Anzeige
AW: Die Objekt-Klasse FullSeriesCollection....
20.02.2018 12:03:10
Burak
ja super, das funktioniert super, danke dir!
Danke (mit weiterem Text)
20.02.2018 12:48:14
UweD
Es waren noch feste Spalten drin...
auch noch durch Variable ersetzt.
Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error GoTo Fehler
    Call Var_Bel
    
    If Not Intersect(EingabeLinie, Target) Is Nothing Then
        With TBTmp
            LR1 = .Cells(.Rows.Count, SSpalte1).End(xlUp).Row 'letzte Zeile der Spalte 
            
            'Alle zellen löschen 
            .Cells.ClearContents
            
            'Erste Spalte in Temporäres Blatt kopieren 
            TB2.Columns(SSpalte1).Copy TBTmp.Columns(ZSpalte)
            
            'Überschriften setzten 
            .Cells(1, ZSpalte + 1) = 0 'wird für Duplikate benötigt 
            .Cells(1, ZSpalte + 2) = "Bis"
            
            LR1 = .Cells(.Rows.Count, ZSpalte).End(xlUp).Row 'letzte Zeile der Spalte 
            
            'Formel reinschreiben und in Werte verwandeln 
            'Wenn "Linie" dann Zeilennummer; sonst 0 
            With .Cells(2, ZSpalte + 1).Resize(LR1 - 1)
                .FormulaR1C1 = "=IF(ISNUMBER(FIND(""Linie"",RC[-1])),ROW()+1,0)"
                .Value = .Value
            End With
            
            'Duplikate entfernen / hier alle Nullen 
            .Columns(ZSpalte).Resize(, 3).RemoveDuplicates Columns:=2, Header:=xlNo
            
            LR2 = .Cells(.Rows.Count, ZSpalte).End(xlUp).Row 'letzte Zeile der Spalte 
            
            'Formeln "BIS" reinschreiben und durch Werte ersetzen 
            With .Cells(2, ZSpalte + 2).Resize(LR2 - 2)
                .FormulaR1C1 = "=R[1]C[-1]-2"
                .Value = .Value
            End With
            
            'Bei letzem "BIS" die letzte Zeile einsetzen 
            .Cells(LR2, ZSpalte + 2) = LR1
           
            'Gültigkeitsbereich für Linien neu ermitteln und festschreiben 
            WB1.Names("G_Linie").RefersTo = _
                 "=" & TBTmp.Name & "!" & Cells(2, ZSpalte).Address & ":" & Cells(LR2, ZSpalte).Address
            
            'Eingabe und Wertebereich löschen 
            Application.EnableEvents = False
            EingabeCodes.ClearContents
            Call Resetten(TB1, EZ + 1, LR1)
            Application.EnableEvents = True

        End With
    End If
    '*** Fehlerbehandlung 
    Err.Clear
Fehler:
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Call Var_Bel
    Application.ScreenUpdating = False
    
    If Not Intersect(EingabeLinie, Target) Is Nothing Then 'Nur bei Änderung der Linie 
        If Target = "" Then Exit Sub
        With TBTmp
            'Von Zeile und Bis Zeile füd die Linie ermitteln 
            Von = .Cells(WorksheetFunction.Match(Target, .Columns(ZSpalte), 0), 2)
            Bis = .Cells(WorksheetFunction.Match(Target, .Columns(ZSpalte), 0), 3)
            
            'Codezeilen für die ausgewählte Linie kopieren 
            TB2.Range(TB2.Cells(Von, SSpalte2), TB2.Cells(Bis, SSpalte2)).Copy _
                TBTmp.Cells(2, ZSpalte + 4)
            
            'Überschrift setzen 
            .Cells(1, ZSpalte + 4) = "Codes von " & Target
            
            'Duplikate entfernen 
            .Columns(ZSpalte + 4).RemoveDuplicates Columns:=1, Header:=xlNo
            
            LR2 = .Cells(.Rows.Count, ZSpalte + 4).End(xlUp).Row
        
        End With

        'Gültigkeitsbereich für Linien neu ermitteln und festschreiben 
        Application.EnableEvents = False
        WB1.Names("G_Codes").RefersTo = _
            "=" & TBTmp.Name & "!" & Cells(2, ZSpalte + 4).Address & ":" & Cells(LR2, ZSpalte + 4).Address
        
        LR1 = TB1.Cells.SpecialCells(xlCellTypeLastCell).Row 'Letzte Zeile des gesamten Blattes 
        
       'Wertebereich löschen 
        Call Resetten(TB1, EZ + 1, LR1)
    End If

    
    If Not Intersect(EingabeCodes, Target) Is Nothing Then ' Nur bei Änderungen der Codes 
    
        Application.EnableEvents = False
        LR1 = TB1.Cells.SpecialCells(xlCellTypeLastCell).Row 'Letzte Zeile des gesamten Blattes 
        
        'Wertebereich löschen 
        Call Resetten(TB1, EZ + 1, LR1)
        Application.EnableEvents = True
        
        'Von Zeile und Bis Zeile ermitteln 
        Von = TBTmp.Cells(WorksheetFunction.Match(EingabeLinie, TBTmp.Columns(ZSpalte), 0), 2)
        Bis = TBTmp.Cells(WorksheetFunction.Match(EingabeLinie, TBTmp.Columns(ZSpalte), 0), 3)
    
        With TB2
            'Autofilter ausschalten 
            If .AutoFilterMode Then .AutoFilterMode = False
            
            'Autofilter auf ausgewählten Code 
            .Range(.Cells(Von - 1, ZSpalte), .Cells(Bis, ZSpalte)).AutoFilter Field:=1, _
                Criteria1:=Target
            
            'gefilterten Bereich kopieren 
            Application.EnableEvents = False
            .Rows(Von & ":" & Bis).Copy TB1.Rows(EZ + 1)
            .AutoFilterMode = False
            
            
            'Zeitstempel aus Datum und Zeit addieren 
            LR1 = TB1.Cells(TB1.Rows.Count, SSpalte1).End(xlUp).Row
            If LR1 > EZ Then
                With TB1.Cells(11, 15).Resize(LR1 - EZ)
                    .FormulaR1C1 = "=RC[-2]+RC[-1]"
                    .NumberFormat = "DD.MM.YYYY hh:mm:ss"
                End With
            End If
            Application.EnableEvents = True
    
        End With

        'in bestehendem Chart den Datenbereich neu einstellen 
        With TB3.ChartObjects("Diagramm 1").Chart
            .SeriesCollection(1).XValues = "='" & TB1.Name & "'!$O$11:$O$" & LR1
            .SeriesCollection(1).Values = "='" & TB1.Name & "'!$E$11:$E$" & LR1
            .SeriesCollection(1).Name = Range("E10") & ": " & EingabeLinie & " / Code: " & Target
            
            'x Achse anpassen 
            MMin = WorksheetFunction.Min(TB1.Range("$O$11:$O$" & LR1))
            MMax = WorksheetFunction.Max(TB1.Range("$O$11:$O$" & LR1))

            .Axes(xlCategory).MinimumScale = MMin
            .Axes(xlCategory).MaximumScale = MMax
            
            'Anzahl der xAchsenBeschriftungen anpassen (mit den 500 spielen) 
            .Axes(xlCategory).MajorUnit = (MMax - MMin + 1) / 500
            
            
            'Y Achse anpassen 
            MMin = WorksheetFunction.Min(TB1.Range("$E$11:$E$" & LR1))
            MMax = WorksheetFunction.Max(TB1.Range("$E$11:$E$" & LR1))
                        
            .Axes(xlValue).MinimumScale = MMin - 20
            .Axes(xlValue).MaximumScale = MMax + 20

        End With
        
        
    End If
    '*** Fehlerbehandlung 
    Err.Clear
Fehler:
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear
End Sub

Private Sub Resetten(TB, E1, LR)
        TB.Rows(E1).Resize(LR - E1 + 1).ClearContents
End Sub


LG UweD
Anzeige

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige