AW: Performance letzter Schritt
06.03.2018 19:10:16
Rudi
Hallo,
das kommt durch deine vielen einzelnen Zellzugriffe. Das braucht halt. Besser erst daten sammeln und dann auf einen Schlag in die Zellen schreiben.
Beispiel:
Sub Ruestwechsel()
'Deklarationen der Variablen
Dim cntr As Long, c As Range, i As Long, Zeilenzahl As Long, Zeilenzahl2 As Long, StartDatum As _
Date, EndDatum As Date, n
Dim Summe, loLetzte As Long, loSpalte, pctCompl As Integer, vntRet As Variant, vorgang As _
String, d As Variant, j As Long
Dim hilfsdatum As String
Dim tt
Application.ScreenUpdating = False
'Fortschrittsbalken auf 0 setzen
progressg pctCompl
'Gesuchtes Datum eingeben
hilfsdatum = InputBox("Bitte geben Sie ein Startdatum ein:")
If hilfsdatum = "" Then Exit Sub
StartDatum = hilfsdatum
hilfsdatum = InputBox("Bitte geben Sie ein Enddatum ein:")
If hilfsdatum = "" Then Exit Sub
EndDatum = hilfsdatum
'Ausgabe- und Hilfsblätter leeren
Worksheets("Hilfstabelle").Cells.Clear
With Worksheets("Linienauswertung - Grafiken")
.Cells.Clear
.Cells(1, 1).Resize(6, 4) = LiesRuestWechsel(StartDatum, EndDatum)
.Cells(8, 1).Resize(6, 4) = LiesRuestZeit(StartDatum, EndDatum)
End With
'Bis hier bei mir 0,004 Sekunden
'Alle 5 Linien
For i = 2 To 6
'Blatt leeren und beschriften
With Worksheets("Hilfstabelle")
.Range("A1").CurrentRegion.Clear
.Range("A1").Resize(, 6) = Array("Barcode", "Masterbarcode", "Schicht", "LP Nutzen", "Datum" _
, "Uhrzeit")
Function LiesRuestWechsel(StartDatum As Date, EndDatum As Date)
Dim arr(1 To 6, 1 To 4)
Dim i As Integer, j As Long
Dim vArr
arr(1, 1) = "Rüstwechsel"
arr(1, 2) = "Früh"
arr(1, 3) = "Spät"
arr(1, 4) = "Nacht"
'Alle 5 Linien
For i = 2 To 6
arr(i, 1) = "R" & i - 1
arr(i, 1) = "R" & i - 1
'Tabellenblatt der Linie
With Worksheets("R" & i - 1)
'Rüstwechsel zählen und ausgeben
vArr = .Cells(1, 1).CurrentRegion.Resize(, 14)
For j = 3 To UBound(vArr)
Select Case vArr(j, 13)
Case StartDatum To EndDatum
If vArr(j, 1) vArr(j - 1, 1) Then
Select Case vArr(j, 6)
Case "FS"
arr(i, 2) = arr(i, 2) + 1
Case "SS"
arr(i, 3) = arr(i, 3) + 1
Case "NS"
arr(i, 4) = arr(i, 4) + 1
End Select
End If
End Select
Next j
End With
Next i
LiesRuestWechsel = arr
End Function
Function LiesRuestZeit(StartDatum As Date, EndDatum As Date)
Dim arr(1 To 6, 1 To 4)
Dim i As Integer, j As Long
Dim vArr
arr(1, 1) = "Rüstwechsel"
arr(1, 2) = "Früh"
arr(1, 3) = "Spät"
arr(1, 4) = "Nacht"
'Alle 5 Linien
For i = 2 To 6
arr(i, 1) = "R" & i - 1
arr(i, 1) = "R" & i - 1
'Tabellenblatt der Linie
With Worksheets("R" & i - 1)
vArr = .Cells(1, 1).CurrentRegion.Resize(, 14)
For j = 3 To UBound(vArr)
Select Case vArr(j, 13)
Case StartDatum To EndDatum
If vArr(j, 1) vArr(j - 1, 1) Then
Select Case vArr(j, 6)
Case "FS"
arr(i, 2) = arr(i, 2) + vArr(j, 5)
Case "SS"
arr(i, 3) = arr(i, 3) + vArr(j, 5)
Case "NS"
If vArr(j, 14) > TimeSerial(21, 59, 59) Then
arr(i, 4) = arr(i, 4) + vArr(j, 5)
End If
End Select
End If
End Select
Next j
End With
Next i
LiesRuestZeit = arr
End Function
weiter geht's hinten mit Zeilen löschen etc. bei der Optimierungsfähigkeit weiter.
Gruß
Rudi