AW: Zusatz
09.02.2018 14:48:18
Peter(silie)
Hallo,
unten Code und Mappe.
Habe einen Test gemacht mit 15000 Zeilen Pro Blatt.
Also 75000 Zeilen Insgesamt die geprüft und evtl. übertragen werden.
Dabei hat die Dauer 3,38 Sekunden betragen.
Wird je nach Rechenleistung und Auslastung der CPU variieren.
Hier deine Mappe nur mit den von mir benötigten Tabellen: https://www.herber.de/bbs/user/119680.xlsm
(Habe auf 400 Zeilen pro blatt gekürzt damit Upload klappt)
Bitte beachte, dass du den Namen der Klasse nicht abändern solltest.
Hier nur Code:
ExecuteAverage Modul:
Option Explicit
Public Sub PutAboveAverageIntoSheet()
Dim sa(1 To 5) As New SheetAverage
Dim i As Long, target_ As Worksheet
Dim lRow As Long
Set target_ = ThisWorkbook.Sheets("Mikrostörungen")
For i = 1 To 5
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
SheetAverage Klasse:
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()
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.Average(rng2) * 1.2
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))
For lRow = 2 To values.Rows.Count
If values(lRow, 1).Value >= averages(lRow, 1).Value Then
ReDim Preserve indizes_(n)
indizes_(n) = lRow
n = n + 1
End If
Next lRow
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), 7)).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, 7)).Value = values
End With
Next i
End With
End Sub
Public Sub RemoveAverages()
sh.Cells(1, 15).EntireColumn.Delete
End Sub