code läuft extrem langsam
29.08.2017 23:12:48
stef26
ich brauch nochmals Unterstützung von Profis. Ich lasse Anmeldezeiten in eine externe XLS schreiben.
Dazu habe ich eine Userform über der ich folgendes mache:
a) Das Bild des Buttons wird auf "Bitte warten" geändert
b) Tabellenblatt leeren
c) Prüfen ob Datei geöffnet ist
d) Wenn sie nicht geöffnet ist, dann den Inhalt kopieren
e) Weiterer Eintrag (aktuelle Zeit) wird vorgenommen und danach zurückgeschrieben
f) Datei gespeichert und geschlossen
g) Bild des Buttons wird wieder zurückgestellt.
Soweit funktioniert alles nach Wunsch. Mein Problem ist, dass diese kleine Aktion ca. 25 Sekunden benötigt. Für Datei öffnen eintragen. Speichern und schliessen.
Datei liegt aktuell noch lokal und öffnet manuell sofort.
Meine Datei mit der Userform lässt sich auch sehr schnell bearbeiten.
Kann mir jemand sagen, warum das so lange dauert?
Bzw. wie ich dies schneller machen kann?
Private Sub Kommen_Click()
'Bild wechsel
Kommen.Picture = LoadPicture(Sheets("setup").Range("B12").Value)
Repaint
'Daten aus MAZeit aktualisieren
Application.ScreenUpdating = False 'Bildschirmreaktionen ausschalten
Dim wb As Workbook: Set wb = ThisWorkbook
Dim WbZ As Workbook
Dim FSO As Object, Verz, SubVerz, Datei, Stapel As Collection, Pfad$
'alte Daten aus der Tabelle entfernen
Sheets("Anwesenheitszeit").Activate
Range("A1:B500").Select
Selection.ClearContents
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'neue Daten einlesen
Application.DisplayAlerts = False 'Meldungen unterdrücken
Pfad = Sheets("Setup").Range("B11").Text 'MAZeiten öffnen
'Funktion Abfrage ob diese Datei soeben geöffnen ist
If DateiGeoeffnet(Pfad) = False Then
Application.AskToUpdateLinks = False
Set WbZ = Workbooks.Open(Pfad)
WbZ.Worksheets(1).Range("A1:B500").Copy
wb.Worksheets("Anwesenheitszeit").Range("A1").PasteSpecial xlValues
Else
'Datei ware bereits geöffnet
MsgBox "Bitte noch einmal probieren, Daten konnten nicht gespeichert werden"
'Bild wechsel
Kommen.Picture = LoadPicture(Sheets("setup").Range("B14").Value)
Repaint
Exit Sub
End If
Dim LoLetzte As Long
Dim Mitarbeiter As Long
wb.Activate
Sheets("Anwesenheitszeit").Activate
Mitarbeiter = Sheets("Anwesenheitszeit").Range("C2").Value
LoLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), _
Cells(Rows.Count, 1).End(xlUp).row, Rows.Count) + 1
Cells(LoLetzte, 1) = Time ' abgelaufene Zeit in Zelle eintragen
Mitarbeiter = Mitarbeiter + 1
Sheets("Anwesenheitszeit").Range("C2").Value = Mitarbeiter
LetzteUhrzeit.Caption = Time
LEWasBox.Caption = "angemeldet"
Calculate
AnzahlMA.Caption = Sheets("Anwesenheitszeit").Range("C2").Value 'Aktuelle Anzahl der _
Mitarbeiter
Zeit.Caption = Format(Sheets("Anwesenheitszeit").Range("E1").Value, "h,mm") & " h"
Zeit2.Caption = Format(Sheets("Anwesenheitszeit").Range("E1").Value, "h,mm") & " h" ' _
Gesamtanwesenheitszeit für die Tabelle Produktivität
'Daten zurückschreiben
wb.Worksheets("Anwesenheitszeit").Range("A1:B500").Copy
WbZ.Worksheets(1).Range("A1").PasteSpecial xlValues
WbZ.Close True
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True 'Meldungen wieder aktivieren
Application.ScreenUpdating = True 'Bildschirmreaktionen einschalten
'Bild wechsel
Kommen.Picture = LoadPicture(Sheets("setup").Range("B14").Value)
Repaint
End Sub
Private Function DateiGeoeffnet(DerPfad As String) As Boolean
On Error Resume Next
Open DerPfad For Binary Access Read Lock Read As #1
Close #1
If Err.Number 0 Then
DateiGeoeffnet = True
Err.clear
End If
End Function