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