Reduzierter Schichtkalender extrem langsam
28.09.2016 15:32:05
Stefan
Ich habe leider noch nicht die Übersichtlichkeit über dieses Forum, deshalb bitte nicht böse sein, wenn ich nochmal einen Beitrag von 2008 Anspreche. Ich habe keine Ahnung, wie oder ob ich überhaupt auf diesen alten Thread aktivieren kann.
Ich hoffe hier natürlich den Ersteller des Skriptes mit meiner Frage zu erreichen.
Hier ist erstmal der Link zu dem alten Thread:
https://www.herber.de/forum/archiv/960to964/961714_Schichtkalender.html
"Klaus-Dieter" hat im vorletzten Beitrag eine Mappe hochgeladen, die perfekt für meine Bedürfnisse ist. Es geht um 5 Schichtsysteme, die in einen Kalender eingetragen werden.
Diese Mappe habe ich auf das für mich wesentliche reduziert/angepaßt:
- auf 15 Schichtsysteme vergrößert
- Termine/Geburtstage eintragen entfernt (und dazugehörige Module)
- Spinbutton entfernt (und dazugehörige Module)
Das Skript soll nur die 15 vorgegebenen Schichtsysteme in den Kalender eintragen. Ohne Wochenende, ohne Feiertage (das dauert in der Testmappe ca. 1 Sekunde)
In der Testmappe funktioniert das auch super.
Wenn ich das Skript aber in meiner richtigen Arbeitsmappe teste, dauert es ganze 45 Sekunden.
Wenn du im Skript der Testdatei "Application.ScreenUpdating = False" auf "True" setzt, hast du einen Vorgeschmack, wie lange es bei mir dauert.
Als ob jedesmal irgendwas gesucht wird...
Das Skript scheint aber an sich schon Fehler zu beinhalten, denn wenn ich eine echte Fehlerbehandlung statt des "On Error Resume Next" integriere, gibt es Fehlermeldungen zur Typenunverträglichkeit.
Kann mir jemand helfen, dies zu einem funktionierenden (schneller ablaufenden) Skript zu machen ?
Vielen Dank.
Stefan
Sub schichten()
' trägt vorgegebene Schichtfolge in einen Kalender ein
' geschrieben von Klaus-Dieter Oppermann
' am 16.03.2004
' Änderung 28.11.2004 ' Korrektur für Schaltjahr zugefügt
' Änderung 24.07.2005 ' Anzahl der Schichten automatisch eintragen
' Änderung 25.07.05 ' Schichtkürzel automatisch einlesen
' Letzte Änderung 20.03.2008 Planer auf fünf Schichten erweitert
' Variablen deklarieren
Dim sk As Variant ' Schichtfolge
Dim s As Integer ' Schleifenzähler für Tabellenzeilen
Dim zk As Integer ' Schleifenzähler für Schichtkürzel
Dim we As Integer ' Zuweisungsschlüssel
Dim sp As Integer ' Schleifenzähler für Spalten
Dim arr(50, 0) ' Array zum Eintragen der Kürzel
Dim ziel As Integer ' Letzter Tag im Monat
Dim azeintr As Integer ' Anzahl der Schichten
Dim intTeiler As Integer ' Länge des Schichtzyklus
Dim ssp As Integer ' Schicht 1 bis 15
On Error Resume Next ' bei _
Fehler mit Folgeanweisung weitermachen
'On Error GoTo Felerbehandlung
Application.ScreenUpdating = True ' _
Bildschirmaktualisierung aus
azeintr = Sheets("Schichtfolge") _
.Range("A65536").End(xlUp).Row ' Anzahl _
der Schichten ermitteln
ReDim sk(azeintr, 0) ' Anzahl _
der Arrayfelder festlegen
' Kürzel in Feldvariable einlesen
intTeiler = Sheets("Schichtfolge").Range("A65536").End(xlUp).Row - 1 ' Länge dee _
Schichtzyklus ermitteln
For zk = 2 To azeintr ' Laufe von _
1 bis Listenende
Sheets("Schichtfolge").Cells(zk, 2) = _
Sheets("Schichtfolge").Cells(zk, 1) Mod intTeiler ' Werte für _
Arrayfelder berechnen
sk(Sheets("Schichtfolge").Cells(zk, 3), 0) = _
Sheets("Schichtfolge").Cells(zk, 2) ' Schichtkü _
rzel in Array einlesen
Next zk ' _
Schleifenzähler plus 1
' Kürzel in Kalender schreiben
For sp = 1 To 199 Step 17 ' _
Schleife für Spaltenzuweisung
ziel = Cells(Rows.Count, sp).End(xlUp).Row ' Zielwert _
für Schleife
If sp = 9 And Cells(1, 1) Mod 4 0 Then ziel = ziel - 1 ' Korrektur _
für Schaltjahr
For s = 4 To ziel ' Schleife _
für Einträge in Zeilen
For ssp = 1 To 15 ' Aufruf _
Schicht 1 bis 15
Sheets("Kalender").Cells(s, sp + ssp) = Application.Worksheet
Function _
.VLookup(Sheets("Kalender").Cells(s, sp) Mod intTeiler, _
Sheets("Schichtfolge").Range("B2:Q" & azeintr), ssp + 1, False) ' Schicht _
eintragen
Next ssp ' nächste _
Schicht
Next s ' nächster _
Tag
Next sp ' nächster _
Monat
If Sheets("Kalender").Cells(1, 1) Mod 4 0 Then Sheets("Kalender").Range("s32:ag32").Value = " _
Exit Sub
'Fehlerbehandlung:
'MsgBox "Fehler bei der Ausführung" & vbCrLf & "Fehlernummer: " & Err.Number & _
'vbCrLf & "Fehlerbeschreibung: " & Err.Description
End Sub