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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

Beliebteste Forumthreads (12 Monate)

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread