Tipp´s für Performance
24.11.2016 11:47:19
Rob
Hallo liebe Excel-Profis,
ich habe mir hier einen Code zusammengebastelt der eigentlich das tut was er soll. Vorher hatte das reine auslesen der Dateien (Fett markiert) mit den Zeilen kopieren ca. 5-10 min gedauert. Jetzt dauert eine Datei schon über 10 sek.
was rechnerisch bedeuten würde das,dass makro rund 10 stunden laufen müsste.
Ich hoffe es kann mir hier wer helfen bzw. mir einen Tipp geben was die Geschwindigkeit so dermaßen bremst.
Ich bin für jeden hilfreichen Tipp jetzt schon mal dankbar :-)
Grüße Rob
Sub Auslesen()
Dim file As Integer
Dim Kennung As String
Dim Zielpfad As String
Dim Zieldatei As String
Dim UW As String
Dim var As Range
Dim n As Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Kennung = "1"
Zieldatei = Dir("Dateiname")
Zielpfad = "Dateipfad"
k = 1
With Worksheets("Liste")
.Columns("A").Value = .Columns("G").Value
End With
Do While Zielpfad <> ""
With Worksheets("Liste")
.Range("C3:E200").ClearContents
.Range("M:M").ClearContents
End With
Open Zielpfad & Zieldatei For Input As #1
Do While Not EOF(1)
Line Input #1, Zeilen
file = InStr(Zeilen, Kennung)
If file > 0 Then
With Worksheets("Liste")
.Cells(Rows.Count, 3).End(xlUp).Offset(1) = Mid$(Zeilen, 19, 13)
.Cells(Rows.Count, 4).End(xlUp).Offset(1) = Mid$(Zeilen, 54, 6)
.Cells(Rows.Count, 5).End(xlUp).Offset(1) = Mid$(Zeilen, 62, 6)
End With
End If
Loop
Close #1
Worksheets("Liste").Sort.SortFields.Clear
Worksheets("Liste").Sort.SortFields.Add Key:=Range("C3"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Liste").Sort
.SetRange Range("C3:E196")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Sheets("Liste").Range("K3:N76").Calculate
m = 0
For i = 3 To 196
If Cells(i, 1) <> Cells(i, 3) Then
UW = Left(Range(Cells(i, 1), Cells(i, 1)), 4)
With Worksheets("Liste")
Set var = .Range("J3:J76").Find(UW, LookIn:=xlValues, lookat:=xlWhole)
If Not var Is Nothing Then
n = var.Row
Else
MsgBox "Fehler in Find.Funktion bei Zeile " & i
End If
If .Cells(n, 14) = 0 Then
.Range(Cells(i, 3), Cells(i, 5)).Insert Shift:=xlDown
.Cells(n, 13) = 1
.Range("N3:N76").Calculate
Else
.Cells(i, 1) = .Cells(i, 3)
m = 1
End If
End With
End If
Next
Worksheets("Liste").Sort.SortFields.Clear
Worksheets("Liste").Sort.SortFields.Add Key:=Range("A3"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Worksheets("Liste").Sort
.SetRange Range("A3:A196")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
If m = 1 Then
Worksheets("Liste").Range("C2:E196").Copy
Worksheets("Tabelle").Cells(Rows.Count, 2).End(xlUp).Offset(1).PasteSpecial Transpose:= _
True
Worksheets("Tabelle").Cells(2 * k, 1) = Left$(Zieldatei, 13)
Worksheets("Tabelle").Cells(2 * k + 1, 1) = Left$(Zieldatei, 13)
Else
Worksheets("Liste").Range("D2:E196").Copy
Worksheets("Tabelle").Cells(Rows.Count, 2).End(xlUp).Offset(1).PasteSpecial Transpose:= _
True
Worksheets("Tabelle").Cells(2 * k, 1) = Left$(Zieldatei, 13)
Worksheets("Tabelle").Cells(2 * k + 1, 1) = Left$(Zieldatei, 13)
End If
Zieldatei = Dir
k = k + 1
Loop
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub