Langsames Makro beschleunigen

Guten Morgen zusammen,
mein Makro quält mich nun schon seit Tagen. Es ist einfach MEGA LANGSAM. Ich habe mich durch die einschlägigen Beiträge gelesen und diverse Anpassungen vorgenommen - aber die Performance ist bescheiden. Wäre klasse, wenn ihr mir helfen würdet.
Zum Makro: Es soll auf Basis von drei Selektionskriterien Zeile für Zeile durchgehen und bei einem Match eine Zeile duplizieren und an diversen Stellen (Zellen) Änderungen / Einträge vornehmen.
So sieht das aktuell aus:


Sub RUESTEN_separieren_Tabellenblatt()
Dim zeile As Integer
Dim rueckmeldeart As String
zeile = ActiveCell.Row
rueckmeldeart = ""
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Do Until zeile = 6000 Or Range("A" & zeile).Value = "" And Range("I" & zeile).Value = ""
If ActiveCell.Offset(0, 10).Value = "Arbeit" And ActiveCell.Offset(0, 12).Value  "" And    _
_
_
ActiveCell.Offset(0, 14).Value  "" Then
Rows(zeile).Select
Selection.Copy
Selection.Insert Shift:=xlDown
ActiveCell.EntireRow.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Activate
ActiveCell.Offset(0, 6).Value = "AFO0001"
ActiveCell.Offset(0, 7).Value = "Rüsten"
ActiveCell.Offset(0, 12).Value = ""
ActiveCell.Offset(0, 15).Value = ""
ActiveCell.Offset(0, 16).Value = "nach Maschinen- und Einstellblatt"
ActiveCell.Offset(1, 14).Value = ""
rueckmeldeart = ActiveCell.Offset(1, 20).Value
ActiveCell.Offset(0, 20).Value = rueckmeldeart
ActiveCell.Offset(0, 22).Value = "A1"
ActiveCell.Offset(1, 22).Value = "A2"
Else
ActiveCell.Offset(1, 0).Select
End If
Range("A" & zeile).Activate
zeile = zeile + 1
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Call Calculate
End Sub

Die Zeilensuche funktioniert ganz ordentlich hinsichtlich Geschwindigkeit - nur die Zeilenbearbeitung... Die wird von Zeile für Zeile langsamer.
Für eure Rückmeldungen - schon mal herzlichen Dank

Hi
probier mal diesen Code.
er liefert bei mir mir der Beispieldatei das gleiche Ergebnis wie dein Code, sollte aber etwas schneller sein, auch bei größeren Datenmengen.
ich hab ein paar Kommentare eingefügt, damit du siehst was in diesem Programmabschnitt gemacht wird.
der Ablauf entspricht dem, was ich in meinem ersten Beitrag beschrieben habe.
durch die Zeilennummer in der Hilfsspalte wird die korrekte Rücksortierung gewährleistet.

Sub RüstenEinbauen()
Dim S1 As Long, S2 As Long
Dim rng1 As Range, rng2 As Range
With ActiveSheet.UsedRange
'--- Reihenfolge sichern
With .Columns(.Columns.Count + 1)
S1 = .Column
.Cells(1, 1).Value = 1
.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1
End With
'--- zu bearbeitende Zeilen kennzeichnen
With .Columns(.Columns.Count + 2)
S2 = .Column
.FormulaR1C1 = "=if(AND(RC11=""Arbeit"",RC13"""",RC15""""),1,"""")"
.Formula = .Value
End With
End With
With ActiveSheet.UsedRange
'--- umsortieren, zu kopierende Zeilen in einen Block
.Sort Key1:=.Cells(1, S2), order1:=xlAscending, Header:=xlNo
'--- kopieren, dabei kopier und einfügebereich in Variablen merken
Set rng1 = Intersect(.Cells, .Columns(S2).SpecialCells(xlCellTypeConstants, 1).EntireRow)
rng1.Copy
Cells(.Row + .Rows.Count, 1).PasteSpecial xlPasteAll
Set rng2 = Selection
'--- Bearbeigung durchführen
With rng1
.Columns(7).Value = "AF00001"
.Columns(8).Value = "Rüsten"
.Columns(13).ClearContents
.Columns(16).ClearContents
.Columns(17).Value = "nach Maachinen- und Einstellblatt"
.Columns(23) = "A1"
End With
With rng2
.Columns(23) = "A2"
.Columns(15).ClearContents
End With
End With
'--- Rücksortieren und Hilfsspalten leeren
With ActiveSheet.UsedRange
.Sort Key1:=.Cells(1, S1), order1:=xlAscending, Header:=xlNo
.Columns(S1).ClearContents
.Columns(S2).ClearContents
End With
End Sub

wie gesagt, ich habe den Code mit deinen Beispieldaten getestet.
probiers mal mit deinen Echtdaten.
Gruß Daniel

Forumthread: Langsames Makro beschleunigen

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial