also ich habe hier im Forum letztes Mal ein super Code bekommen, aber der mir zu hoch ist :D
An Stellen, die ich verstanden habe, konnte ich einige Anpassungen vornehmen, aber ein gravierender Teil fehlt noch.
Der Modulcode:
Option Explicit
Public Sub PutAboveAverageIntoSheet()
Dim sa(1 To 5) As New SheetAverage
Dim target2_ As Worksheet, target_ As Worksheet
Dim lRow As Long, i As Long
Set target_ = ThisWorkbook.Sheets("Mikrostörungen")
Set target2_ = ThisWorkbook.Sheets("Störungen")
target_.Cells.Clear
target2_.Cells.Clear
For i = 1 To 5
lRow = target2_.Cells(target2_.Rows.Count, 1).End(xlUp).Row + 1
target2_.Cells(lRow, 1).Value = "R" & i
lRow = target_.Cells(target_.Rows.Count, 1).End(xlUp).Row + 1
target_.Cells(lRow, 1).Value = "R" & i
Set sa(i).DataSheet = ThisWorkbook.Sheets("R" & i)
sa(i).PutAverage
sa(i).CreateIndizes
sa(i).PutIndizedValues ThisWorkbook.Sheets("Mikrostörungen")
sa(i).RemoveAverages
Next i
End Sub
Der Klassenmodulcode:
Option Explicit
Private indizes_() As Long
Private sh As Worksheet
Public Property Set DataSheet(ByRef this_ As Worksheet)
Set sh = this_
End Property
Public Sub PutAverage()
'Deklaration der Variablen
Dim lRow As Long, flag As String
Dim rng As Range, rng2 As Range
Dim i As Long, j As Long, avrg As Long
With sh
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set rng = .Range(.Cells(2, 1), .Cells(lRow, 1))
flag = .Cells(2, 1).Value
j = 2
For i = 2 To lRow
If rng(i - 1, 1).Value flag Then
Set rng2 = .Range(.Cells(j, 5), .Cells(i - 1, 5))
avrg = Application.WorksheetFunction.TrimMean(rng2, 0.8)
Set rng2 = .Range(.Cells(j, 15), .Cells(i - 1, 15))
rng2.Value = avrg
flag = rng(i, 1)
j = i - 1
End If
Next i
End With
End Sub
Public Sub CreateIndizes()
Dim lRow As Long, n As Long
Dim values As Range, averages As Range
With sh
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set values = .Range(.Cells(1, 5), .Cells(lRow, 5))
Set averages = .Range(.Cells(1, 15), .Cells(lRow, 15))
'Geh die Liste ab
For lRow = 2 To values.Rows.Count
'Wenn der Zeitwert zwischen 200% und 500% vom Durchschnitt liegt
If values(lRow, 1).Value >= averages(lRow, 1).Value * 2 And values(lRow, 1).Value
End With
End Sub
Public Sub PutIndizedValues(ByRef TargetSheet As Worksheet)
Dim lRow As Long, i As Long
Dim values As Variant
With sh
For i = LBound(indizes_) To UBound(indizes_)
values = .Range(.Cells(indizes_(i), 1), .Cells(indizes_(i), 14)).Value
lRow = TargetSheet.Cells(TargetSheet.Rows.Count, 1).End(xlUp).Row + 1
With TargetSheet
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Range(.Cells(lRow, 1), .Cells(lRow, 14)).Value = values
End With
Next i
End With
End Sub
Public Sub RemoveAverages()
sh.Cells(1, 15).EntireColumn.Delete
End Sub
Im Modulcode sieht man das zweite Worksheet für die Variable target2_.Im Klassenmodulcode gibt es diesen Part
'Geh die Liste ab
For lRow = 2 To values.Rows.Count
'Wenn der Zeitwert zwischen 200% und 500% vom Durchschnitt liegt
If values(lRow, 1).Value >= averages(lRow, 1).Value * 2 And values(lRow, 1).Value
ReDim Preserve indizes_(n)
indizes_(n) = lRow
n = n + 1
End If
Next lRow
Das habe ich schon angepasst, aber jetzt benötige ich dazu noch, dass wenn er über 500% und unter 1000% liegt, er es in das andere Worksheet target2_ genauso schreibt wie er es hier in target_ macht.
Leider verstehe ich diesen Part mit
ReDim Preserve indizes_(n)
indizes_(n) = lRow
wirklich null. :(Wie baue ich das zweite If da mit ein?
Danke und freundliche Grüße