Makro wird immer langsamer bis Absturz
20.08.2020 12:56:36
Mike
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 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.
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