Makro beschleunigen
04.10.2017 20:13:54
Anja
ich bin absoluter Makro-Neuling und habe mir folgendes Makro "zusammengebastelt". Ziel soll es sein, aus einem Tabellenblatt all diejenigen Zeilen zu kopieren, in denen in einer Spalte die Werte mit einer bestimmten Zahl bzw. Buchstaben anfangen. Diese Zeilen sollen in ein anderes Tabellenblatt kopiert werden.
Soweit klappt das. Allerdings ist das Makro sehr langsam, da über 100000 Zeilen durchsucht werden müssen. Gibt es eine Möglichkeit, das Makro zu ändern, damit es schneller läuft?
Hier in meinem Beispielmakro habe ich nur zwei verschiedene Werte, in der Realität werden es später mehr sein.
Ich danke Euch schon mal vorab für Eure Hilfe bzw. Hinweise.
Viel Grüsse
Sub Kopieren()
Application.ScreenUpdating = False
' Tabelle: Tabelle1
' Tabelle Ziel: Ziel
Const Blatt1 = "Tabelle1" ' Source
Const Blatt2 = "Ziel" ' Ziel
Dim I As Long
Dim iAnz As Long
Dim letzte As Long
Worksheets("Ziel").Activate
letzte = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
Worksheets("Ziel").Range("A2:AA" & letzte).Clear
Worksheets("Ziel").Range("a2").Activate
Sheets(Blatt1).Activate
Range("e2").Select
iAnz = 0
I = 0
Do Until I = ActiveSheet.UsedRange.Rows.Count
If ActiveCell Like "1*" Then
Selection.EntireRow.Copy
Sheets(Blatt2).Activate
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Select
Sheets(Blatt1).Select
ActiveCell.Offset(1, 0).Select
iAnz = iAnz + 1
ElseIf ActiveCell Like "A2*" Then
Selection.EntireRow.Copy
Sheets(Blatt2).Activate
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Select
Sheets(Blatt1).Select
ActiveCell.Offset(1, 0).Select
iAnz = iAnz + 1
Else
ActiveCell.Offset(1, 0).Select
End If
I = I + 1
Loop
MsgBox "Es wurden " & iAnz & " Sätze übertragen"
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub