Guten Tag an das Forum,

ich habe ein Makro erstellt (siehe unten) das Funktioniert auch ganz gut.

Allerdings ist es sehr langsam, bei einer Übergabe von 5000 Zeilen benötigt es ca. 40 Minuten.

Meine Frage kann man das Beschleunigen oder habe ich hier ein Fehler drin?

Sub Übergabe_Kalku()
Application.EnableEvents = False 'Bildschirm abschalten
' Übergibt die Werte der Ausarbeitung an die Kalkulation
On Error Resume Next 'Fehler beim Auftreten unterdrücken und das Makro weiterlaufen lassen
Worksheets("Ausarbeitung").Unprotect Password:="xxx" 'Blattschutz AUS
Worksheets("Kalkulation").Unprotect Password:="xxx"  'Blattschutz AUS
Dim lr As ListRow
Dim lo1 As ListObject
Dim lo2 As ListObject
Dim zMax1 As Long
Dim zMax2 As Long
Dim diff As Long
Dim i As Long

Set lo1 = Worksheets("Ausarbeitung").ListObjects("Tab_Ausarbeitung")
Set lo2 = Worksheets("Kalkulation").ListObjects("Tab_Kalkulation")
zMax1 = lo1.ListRows.Count
zMax2 = lo2.ListRows.Count
diff = zMax1 - zMax2

If diff > 0 Then

For i = 1 To diff
Set lr = lo2.ListRows.Add
Next i

ElseIf diff < 0 Then

For i = zMax2 To zMax2 + diff Step -1
lo2.ListRows(i).Delete
Next i

End If
Range("Tab_Kalkulation[Pos.]").Value = Range("Tab_Ausarbeitung[Pos.]").Value
    Range("Tab_Kalkulation[KD Text 1]").Value = Range("Tab_Ausarbeitung[KD Text 1]").Value
    Range("Tab_Kalkulation[Lieferant]").Value = Range("Tab_Ausarbeitung[Lieferant]").Value
    Range("Tab_Kalkulation[Sonepar-Nr.]").Value = Range("Tab_Ausarbeitung[Sonepar-Nr.]").Value
    Range("Tab_Kalkulation[Artikeltext]").Value = Range("Tab_Ausarbeitung[Artikeltext]").Value
    Range("Tab_Kalkulation[Hersteller Artikel-Nr.]").Value = Range("Tab_Ausarbeitung[Hersteller Artikel-Nr.]").Value
    Range("Tab_Kalkulation[Menge]").Value = Range("Tab_Ausarbeitung[Menge]").Value
    Range("Tab_Kalkulation[PE]").Value = Range("Tab_Ausarbeitung[PE]").Value
    Range("Tab_Kalkulation[ME]").Value = Range("Tab_Ausarbeitung[ME]").Value
Worksheets("Ausarbeitung").Protect Password:="xxx" 'Blattschutz EIN
Worksheets("Kalkulation").Protect Password:="xxx"  'Blattschutz EIN

 Application.EnableEvents = True ' Bildschierm einschalten
End Sub

Ich würde mich freuen wenn mir jemand Hefen könnte, meine Erfahrungen mit VBA sind da nicht ausreichend.

Vielen Dank in voraus.

Björn