Optimieren von Funktionen möglich?
12.02.2017 09:58:57
Funktionen
Hallo,
beide Funktionen laufen, jedoch brauchen sie lange zum Ausführen, wenn die Tabelle sehr lang wird- z.B. 3000 Datensätze im Bereich von A-L.
Zeile Einfügen und Rest nach unten verschieben- fügt mir eine Leerzeile ein und
Zeile Löschen und Rest nach oben verschieben- löscht eben mal die aktive Zeile.
Gibt es für diese Funktionen auch schnellere Möglichkeiten?
Sub nachUnten()
' Zeile Einfügen und Rest nach unten verschieben, mit Erweiterung _
NR in SpalteA
Dim lngLetzte As Long
If Cells(ActiveCell.Row, 1).Value = "" Then Exit Sub
Cells(ActiveCell.Row, 2).Resize(1, 13).Insert Shift:=xlDown, CopyOrigin:= _
xlFormatFromLeftOrAbove
lngLetzte = Cells(ActiveCell.Row, 1).End(xlDown).Row
If lngLetzte = ActiveSheet.Rows.Count Then
Cells(ActiveCell.Row + 1, 1) = Cells(ActiveCell.Row, 1) + 1
ElseIf Application.WorksheetFunction.CountA(Cells(lngLetzte + 1, 2).Resize(1, 13)) = 0 Then
Cells(lngLetzte + 1, 2).Resize(1, 13).Delete Shift:=xlUp
Else
Cells(lngLetzte + 1, 1) = Cells(lngLetzte, 1) + 1
End If
End Sub
Sub nachOben()
' Zeile Löschen und Rest nach oben verschieben
Application.ScreenUpdating = False
Dim lngLetzte As Long
Dim lngZeile As Long
lngZeile = ActiveCell.Row
lngLetzte = Cells(ActiveCell.Row, 1).End(xlDown).Row
If Cells(ActiveCell.Row + 1, 1).Value = "" _
Or Cells(ActiveCell.Row, 1).Value = "" Then
Cells(ActiveCell.Row, 2).Resize(1, 13).ClearContents
Else
Cells(ActiveCell.Row, 2).Resize(1, 13).Delete Shift:=xlUp
Cells(lngLetzte, 2).Resize(1, 13).Insert Shift:=xlDown
Cells(lngLetzte - 1, 2).Resize(1, 13).Copy
Cells(lngLetzte, 2).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
Cells(lngZeile, 3).Select
End If
Application.ScreenUpdating = True
End Sub
Gruß Andi
Anzeige