Makro wird immer langsamer bis absturz
10.09.2020 08:31:49
Mike
irgendwie kann ich leider auf meinen letzten Beitrag keine Antworten mehr schreiben daher muss ich das Thema nochmal neu erstellen.
Das nachfolgende Makro soll nach und nach Dateien öffnen (pro KW gibt es eine Datei) und aus den Dateien jeweils von TAB 4 bis 20 aus Zelle D6 den Wert in wsZiel kopieren.
Im Grunde funktioniert das auch (Makro im Einzelschritt läuft Problemlos) aber ich muss fesstellen, dass der Ablauf nach jedem durchlaufenen Workbook langsamer wird bis Excel sich schließlich verabschiedet. Ich habe erst gedacht es könnte mit der Zwischenablage zusammenhängen aber auch das explizite leeren dieser hat nichts gebracht.
Vielleicht kann ja jemand mal drüber schauen ob ihr irgendwo einen mittelgroßen Fehler finden könnt der mir bislang nicht aufgefallen ist.
Ich habe zwischenzeitlich den Tipp von Hanssueli bekommen nach getmorespeed zu schauen aber musste feststellen, dass ich das quasi bereits über call EventsOff/On umgesetzt habe.
Nach wie vor bin ich mir nicht wirklich sicher ob ich vielleicht einen grundlegenden Fehler im eigentlich Ablauf meines Programms habe der letztlich dafür sorgt. Aber soweit ich das sehe sollte der Code als solches doch eigentlich in Ordnung sein oder?
Option Explicit
Sub Stueckzahlen1()
Dim wsZiel As Worksheet
Dim pathQuelle As String
Dim wbQuelle As Workbook
Dim wsQuelle As Worksheet
Dim i As Byte
Dim Kwaktuell As String
Dim strKw As String
Dim z As Byte
Dim t As Byte
Dim strMaschine As String
Call EventsOff
strMaschine = "Smart1"
Set wsZiel = ThisWorkbook.Sheets("Smart1 Mengen")
Kwaktuell = Format(Date, "ww")
For i = 2 To Kwaktuell - 1
If wsZiel.Cells(i, 2).Value = "" Then
strKw = wsZiel.Cells(i, 1).Value
pathQuelle = "\\test.com\Zeiten\" & strMaschine & "\2020\" & strKw & " Zeiten _
" & strMaschine & ".xlsm"
Set wbQuelle = Workbooks.Open(Filename:=pathQuelle, ReadOnly:=True)
z = 2
For t = 4 To 20
wbQuelle.Sheets(t).Cells(6, 4).Copy
wsZiel.Cells(i, z).PasteSpecial Paste:=xlValues
' Application.CutCopyMode = False
z = z + 1
Next t
wbQuelle.Close SaveChanges:=False
End If
Next i
Call EventsOn
End Sub
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Gruß
Mike