Ausfuehrung Code dauert sehr lange
14.09.2015 18:20:39
Juergen
ich habe eine lange Liste (800.000 Zeilen), deren Inhalt ich je nach dem was in Spalte A fuer ein Zahlencode steht, in eine andere Tabelle ueberfuehre. Herausforderung ist lediglich an die richtige Stelle zu kommen, deshalb viele Spruenge mit xltoright, xlup, ...
Es funktioniert ansich ganz gut. ABER, ich benoetige fuer 1000 Zeilen bereits 5 Minuten. Wenn ich das hochrechne, dauern die 800.000 Zeilen 67 Stunden.
Ich bin mir sicher, man kann den Code verschlanken, leider reicht mein Anfaenger-VBA-Koennen nicht um beurteilen zu koennen wo man ansetzt.
Sieht jemand Potenzial, damit das schneller laeuft? Oder muss ich mich mit den 60 Stunden anfreunden?
Sub Copy()
Sheets("2-cut").Select
Application.ScreenUpdating = False
For t = 1 To 1000 'aktuell 1000 Zeilen, eigentlich aber 800.000
If Cells(t, 1).Value = "1" Then
Cells(t, 3).Select
Range(Selection, Selection.End(xlToRight)).Cut
Sheets("Final").Select
Range("A1048576").Select
Selection.End(xlUp).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
Sheets("2-cut").Select
ElseIf Cells(t, 1).Value = "4" Then
Cells(t, 3).Select
Range(Selection, Selection.End(xlToRight)).Cut
Sheets("Final").Select
Range("A1048576").Select
Selection.End(xlUp).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
Sheets("2-cut").Select
ElseIf Cells(t, 1).Value = "2" Then
Cells(t, 3).Select
Selection.Clear
Cells(t, 4).Select
Selection.Cut
Sheets("Final").Select
Range("A1048576").Select
Selection.End(xlUp).Select
Cells(ActiveCell.row, 15).Activate
ActiveSheet.Paste
Sheets("2-cut").Select
ElseIf Cells(t, 1).Value = "3" Then
Cells(t, 3).Select
Selection.Clear
Cells(t, 4).Select
Selection.Cut
Sheets("Final").Select
Range("A1048576").Select
Selection.End(xlUp).Select
Cells(ActiveCell.row, 15).Activate
Selection.End(xlToRight).Select
Selection.Offset(0, 1).Select
ActiveSheet.Paste
Sheets("2-cut").Select
ElseIf Cells(t, 1).Value = "5" Then
Cells(t, 3).Select
Selection.Clear
Cells(t, 4).Select
Selection.Cut
Sheets("Final").Select
Range("A1048576").Select
Selection.End(xlUp).Select
Cells(ActiveCell.row, 16).Activate
ActiveSheet.Paste
Sheets("2-cut").Select
End If
Next t
Application.ScreenUpdating = True
End Sub
Vielen Dank
Anzeige