Makro ist sehr langsam
Susanne
ich hoffe auf eure kompetente Unterstützung. Ich habe ein Makro, das zwar macht was es soll, jedoch braucht es ca 4 Minuten pro Datei im Verzeichnis. Habt ihr eine Idee wie man das ganze beschleunigen könnte?
Kurz zur Erklärung: Der Code soll in einer Auswertungsmappe eine Tabelle aus einer anderen Mappe einfügen, diese kopieren und unter die letzte beschriebene Zeile einfügen und dann alle Verknüpfungen ersetzen. Das macht er für jede Datei im angegebenen Verzeichnis. ZUm Schluss löscht es die Ausgangstabelle, da diese nur als Basis für die Ersetzungen dient, und blendet alle Zellen mit dem Wert null aus. Hier der Code:
Sub MitarbeiterEinfügen()
Dim rngCell As Range
Dim row As Long, i As Long
Dim rngRange As Range
Dim Wert As Date
Dim Cell As Range
Dim FileArr As Variant
Dim PathStr As String
Dim FileStr As String
With Application
.ScreenUpdating = False 'ausschalten der Bildschirmaktualisierung
.Calculation = xlCalculationManual
End With
Worksheets("Daten_Controlling").Activate
' Ausgeblendete Zeilen wieder einblenden
Cells.EntireRow.Hidden = False
'Alles löschen ab Zeile 6
Range(Range("A6"), _
Range("A6").End(xlDown)).EntireRow.Delete
'aus Basisdatei Grundlage kopieren
Workbooks("Zeiterfassung_Auswertung_Grundlage3").Worksheets("Basis").Range("A6:M365").Copy
Workbooks("Zeiterfassung_Auswertung_Controlling").Worksheets("Daten_Controlling").Range("A6") _
.Insert
'Anpassen----------------------------------------
PathStr = ActiveSheet.Range("B1").Value 'wenn Pfad gleichbleibend"
'Verzeichnis holen
'------------------------------------------------------------------------------------------- _
VerzeichnisHolen:
If PathStr = "" Then PathStr = GetPath()
If PathStr = "" Then
MsgBox "Es wurde weder ein Pfad angegeben noch ausgewählt!"
Exit Sub
End If
'Dateien aus Verzeichnis holen
'------------------------------------------------------------------------------------------- _
With Application.FileSearch
.LookIn = PathStr
.FileType = msoFileTypeExcelWorkbooks
If .Execute = 0 Then
If MsgBox("Verzeichnis ist leer!" & vbLf & "Wollen Sie ein anderes wählen?", _
vbYesNo) = vbYes Then
PathStr = ""
GoTo VerzeichnisHolen
Else
Exit Sub
End If
Else
ReDim FileArr(1 To .FoundFiles.Count)
For i = 1 To .FoundFiles.Count
FileArr(i) = .FoundFiles(i)
Next
End If
End With
'neuen Mitarbeiter einfügen
'------------------------------------------------------------------------------------------- _
For i = 1 To UBound(FileArr)
PathStr = Left(FileArr(i), Len(FileArr(i)) - Len(Dir(FileArr(i))))
FileStr = Dir(FileArr(i))
Range("A6:M365").Copy
Cells(Cells(Rows.Count, 1).End(xlUp).row + 1, 1).Select
ActiveSheet.Paste
Selection.Replace What:="C:\Beispielpfad\[Kostenstelle_Name_Vorname.xls]", Replacement:= _
PathStr & "[" & FileStr & "]", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
Next
'Grundlage wieder löschen
Range("A6:A365").EntireRow.Delete
'Zeilen mit Null Zeit ausblenden
'------------------------------------------------------------------------------------------- _
For Each Cell In Range(Range("K6"), Range("K6").End(xlDown))
Wert = Cell.Value
If Wert = "0:00:00" Then Cell.EntireRow.Hidden = True
Next Cell
With Application
.ScreenUpdating = True 'ausschalten der Bildschirmaktualisierung
.Calculation = xlCalculationAutomatic
End With
End Sub
Private Function GetPath() As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Ordner auswählen"
.Show
If .SelectedItems.Count 1 Then
Exit Function
Else
GetPath = .SelectedItems(1)
End If
End With
End Function
Liebe Grüße,
Susanne