Export Code arbeit sehr langsam

Sub Export()
Dim ArrayÜberschrift(1 To 79) As Variant, ArrayWerte() As Variant
Dim x As Long, z As Long
Dim i As Long, y As Long, lngSpalte As Long
Dim rSuche As Range, rFinde As Range
With Application
.ScreenUpdating = False 'geänderte Daten werden nicht dargestellt, Bilschirm wird nicht  _
aktualisiert
.EnableEvents = False
.ActiveSheet.Unprotect
End With
Application.Windows.Arrange ArrangeStyle:=xlArrangeStyleTiled
Workbooks.Open Filename:="C:\Users\cmazilu\Arbeitsumgebung\Testing\Input.xls" ' Hier  Pfad _
anpassen z.B.Filename:="C: _
'Application.Windows.Arrange ArrangeStyle:=xlArrangeStyleTiled 'Fenster werden geteilt _
dargestellt
ThisWorkbook.Activate
For i = 1 To 79
ArrayÜberschrift(i) = ThisWorkbook.Sheets("Invoing_list").Cells(1, i + 1)
Next i
With Workbooks("Input.xls").Sheets("Invoing_list")
lz = ThisWorkbook.Sheets("Invoing_list").Cells(Rows.Count, "B").End(xlUp).Row 'sucht die  _
_
letzte benutzte Zeile in Spalte B
lz_input = .Cells(Rows.Count, "B").End(xlUp).Row 'sucht die letzte benutzte Zeile in _
Spalte B
Min = 2 'es wird erst in der 2. Reihe begonnen.
Set rFinde = .Range("A1:CA1")
For i = 1 To 79
Set rSuche = rFinde.Find(what:=ArrayÜberschrift(i), LookAt:=xlWhole, LookIn:= _
xlValues)
If Not rSuche Is Nothing Then
For x = 2 To lz
If ThisWorkbook.Sheets("Invoing_list").Cells(x, i + 1).EntireRow.Hidden =  _
False _
Then
ReDim Preserve ArrayWerte(y)
ArrayWerte(y) = ThisWorkbook.Sheets("Invoing_list").Cells(x, i + 1)
y = y + 1
End If
Next x
lngSpalte = rSuche.Column
For z = LBound(ArrayWerte()) To UBound(ArrayWerte())
.Cells(lz_input + z + Min, lngSpalte) = ArrayWerte(z)
Next z
End If
ReDim ArrayWerte(0)
y = 0
Next i
End With
Workbooks("Input.xls").save
Workbooks("Input.xls").Close
Set rSuche = Nothing
Set rFinde = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
.ActiveSheet.Protect
End With
End Sub