Makro langsam | Herbers Excel-Forum

Hallo Leute!!!
Ich habe jetzt mein Makro ans laufen bekommen, so wie ich es benötige, danke für eure hilfe!!!!
Jetzt habe ich aber einfach nochmal eine Frage?!
Kann man es etwas schneller bekommen, selbst wenn ich die Daten für nur eine Woche auslese, ist der rechner ganz schön blockiert :-(
Ich habe ja schon vorher ein ähnliches Makro betriben, welches vorher daten aus der selben datei ausgelesen hat, aber dieses läuft deutlich schneller.
Ich werde hier mal beide Makros einstellen, wenn nötig werde ich auch die datei versuchen hochzuladen, da muß ich dann aber erst die Größe minimieren!
hier das Langsame Makro:
Option Explicit
Private Const cstrPath As String = "C:\Dokumente und Einstellungen\Burkhard\Eigene Dateien\test2" 'Verzeichnis
Private Const cstrSheet As String = "Schichteingabe" 'Tabelle
Private Const cstrSheet2 As String = "Auslastung Fertigung" 'Tabelle
Private Const AnzMaschinen = 22 'Anzahl Maschinen in jedem KW-Blatt

Sub AuswertungTage()
Dim strFormula As String, strFile As String, strPath As String, lngKW As Long
Dim vVorgabe, Zeile As Long, Spalte As Long, Tag As Long, Zeile1 As Long, Maschine
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
strPath = IIf(Right(cstrPath, 1) = "\", cstrPath, cstrPath & "\")
With Sheets("TagesDaten")
'nächste leere Zeile in Liste in Spalte "KW"
Zeile = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
If Zeile = 2 Then ' noch keine Daten in Tabelle
lngKW = 1
Else
lngKW = .Cells(Zeile - 1, 2).Value + 1 'nächste KW
vVorgabe = Application.InputBox(Prompt:="Ab welcher KW sollen Daten eingelesen werden?" _
& vbLf & "Bei Eingabe 1 werden alle Daten neu eingelesen" _
& vbLf & "Letzte eingelesene KW: " & lngKW - 1, _
Title:="Tagesdaten der KW einlesen", Default:=lngKW, Type:=1)
If vVorgabe = False Then GoTo Beenden
If vVorgabe < lngKW Then
Zeile1 = Zeile - 1
'Startzeile der gewählten KW ermitteln
Do Until Zeile = 2 Or .Cells(Zeile - 1, 2).Value < vVorgabe
Zeile = Zeile - 1
Loop
'Altdaten ab Start-KW löschen
.Range(.Rows(Zeile), .Rows(Zeile1)).ClearContents
lngKW = vVorgabe
End If
End If
For lngKW = lngKW To 53
strFile = Dir(strPath & "*_KW" & CStr(lngKW) & ".xls*", vbNormal)
If strFile <> "" Then
Zeile1 = Zeile
For Tag = 1 To 6
strFormula = "'" & strPath & "[" & strFile & "]" & cstrSheet & "'!"
Spalte = 8 + (Tag - 1) * 4 '1. Spalte des Tages (Anzahl Schichten)
'Formeln für Jahr-KW-Datum für alle Maschinen
.Range(.Cells(Zeile, 1), .Cells(Zeile + AnzMaschinen - 1, 1)).FormulaR1C1 = _
"=" & strFormula & "R1C1" 'Jahr aus Zelle A2 einlesen
.Range(.Cells(Zeile, 2), .Cells(Zeile + AnzMaschinen - 1, 2)).FormulaR1C1 = _
"=" & strFormula & "R1C2" 'KW aus Zelle C1 einlesen
.Range(.Cells(Zeile, 3), .Cells(Zeile + AnzMaschinen - 1, 3)).FormulaR1C1 = _
"=" & strFormula & "R5C" & Spalte 'Tages-Datum aus Zeile 5
'Formeln für Daten zu den einzelnen Maschinen eintragen
For Maschine = 1 To AnzMaschinen
strFormula = "'" & strPath & "[" & strFile & "]" & cstrSheet & "'!"
.Cells(Zeile, 4).Offset(Maschine - 1, 0).FormulaR1C1 = _
"=" & strFormula & "R" & Maschine + 6 & "C1" 'Maschinen-Nr.
.Cells(Zeile, 5).Offset(Maschine - 1, 0).FormulaR1C1 = _
"=" & strFormula & "R" & Maschine + 6 & "C2"  'Maschine-Produkt
.Cells(Zeile, 6).Offset(Maschine - 1, 0).FormulaR1C1 = _
"=" & strFormula & "R" & Maschine + 6 & "C" & Spalte ' Stück Frühschicht
.Cells(Zeile, 7).Offset(Maschine - 1, 0).FormulaR1C1 = _
"=" & strFormula & "R" & Maschine + 6 & "C" & Spalte + 1 'Stück Spätschicht
.Cells(Zeile, 8).Offset(Maschine - 1, 0).FormulaR1C1 = _
"=" & strFormula & "R" & Maschine + 6 & "C" & Spalte + 2 'Stück Nachtschicht
'.Cells(Zeile, 9).Offset(Maschine - 1, 0).FormulaR1C1 = _
"=" & strFormula & "R" & Maschine + 6 & "C" & Spalte + 3 'Stückzahl geamt
strFormula = "'" & strPath & "[" & strFile & "]" & cstrSheet2 & "'!"
.Cells(Zeile, 9).Offset(Maschine - 1, 0).FormulaR1C1 = _
"=" & strFormula & "R" & Maschine + 6 & "C" & Spalte + 3 'Ist Stückzahl
Next
'1. Zeile für nächsten Tag
Zeile = Zeile + AnzMaschinen
Next
'Formeln durch Werte ersetzen
With .Range(.Cells(Zeile1, 1), .Cells(Zeile - 1, 9))
.Calculate
.Value = .Value
End With
End If
Next
Zeile = .Cells(.Rows.Count, 2).End(xlUp).Row 'letzte Zeile mit Daten
End With
'Formeln/Werte in Monatsauswertung aktualisieren
With Worksheets("Auswertung über Monate")
With .Range("E10:P30")
.FormulaR1C1 = _
"=SUMPRODUCT((RC1=Tagesdaten!R2C4:R" & Zeile & "C4)*(MONTH(R9C)=MONTH(Tagesdaten!R2C3:R" _
_
& Zeile & "C3))*Tagesdaten!R2C9:R" & Zeile & "C9)"
.Calculate
.Value = .Value 'Zeile aktivieren, wenn im Zellbereich keine Formeln stehen sollen
End With
'Erstellung Auswertung über Wochen
'Dim strFormula As String, strFile As String, strPath As String, lngKW As Long
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
End With
'ErrExit:
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
Beenden:
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Sub auswertung()
Dim strFormula As String, strFile As String, strPath As String, lngKW As Long
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
strPath = IIf(Right(cstrPath, 1) = "\", cstrPath, cstrPath & "\")
With Sheets("Auswertung über Wochen")
.Range("E10:BD30") = ""
For lngKW = 1 To 52
strFile = Dir(strPath & "*_KW" & CStr(lngKW) & ".xls*", vbNormal)
If strFile <> "" Then
strFormula = "'" & strPath & "[" & strFile & "]" & cstrSheet & "'!"
.Range(.Cells(10, lngKW + 4), .Cells(30, lngKW + 4)).Formula = _
"=SUMPRODUCT((" & strFormula & "$A$6:$A$24=$A10)*(MOD(COLUMN($H:$AA)-7,4)=0)*" &  _
strFormula & "$H$6:$AA$24)"
End If
Next
.Calculate
.Range("E10:BD30") = .Range("E10:BD30").Value
End With
ErrExit:
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub