Schleife schneller machen

Sub tt() ' erstellt von Matthias L 28.01.2016 16:55:48 Dim x&, i& With Tabelle1 For x = 5000 To 2 Step -1 If .Cells(x, 9) = "TF" Then If .Cells(x, 5) .Cells(x, 6) Then .Rows(x + 1).Insert Shift:=xlDown .Cells(x + 1, 5) = .Cells(x, 6) .Cells(x + 1, 6) = .Cells(x, 6) .Cells(x, 6) = .Cells(x, 5) .Cells(x + 1, 4) = .Cells(x, 4) .Cells(x + 1, 7) = .Cells(x, 7) .Cells(x + 1, 8) = .Cells(x, 8) .Cells(x + 1, 9) = .Cells(x, 9) End If End If Next End With End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
mir ist in der Beispieldatei eine Unstimmigkeit aufgefallen.
die müsste zuerst geklaert werden, sonst ist Makro Entwickeln "Bure Kappes" (Eifel)
In der Ausgangslage sehe ich eine blaue markierte Zeile und eine rote.
Laesst man das Makro ablaufen werden von unten Zellen nachgeschoben.
D.h. als Ergebnis gibt es jetzt 2 rote/blaue Zeilen untereinander!
Im Wunschergebnis sehe ich aber TF am Zeilen Ende, jetzt 2 rote und blaue Zeilen
Das ist aber ein ganz anderes Ergebnis! Was ist denn hier wirklich gewünscht?
Das Wunschergebnis liesse sich so zunaechst einmal durch Sortieren bearbeiten.
Dann brauche ich nicht durch 5000 oder mehr Zeilen zu laufen um Zellen einzufügen.
Statt For Next kann man auch über FindNext "TF" gehen. Das dürfte schneller sein.
mfg Piet

Hi zusammen,
mein Ansatz nutzt nur geschicktes Sortieren und *minimale* Kopieraktionen, und das ist auch bei großen Datenmengen fix:

Option Explicit
Sub mm()
' erstellt von Michael
Dim maxz&, zeilen&
Dim c As Range
With Tabelle1
maxz = .Range("H" & Rows.Count).End(xlUp).Row
.Range("J2:J" & maxz).FormulaLocal = "=(I2=" & Chr(34) & "TF" & Chr(34) & ")+(E2F2)"
.Range("C2:J" & maxz).Sort key1:=.Range("J2")
Set c = .Range("J2:J" & maxz).Find(2, LookIn:=xlValues)
If Not c Is Nothing Then
zeilen = maxz - c.Row + 1
.Range("C" & c.Row & ":J" & maxz).Copy .Range("C" & maxz + 1)
.Range("E" & c.Row & ":E" & maxz).Copy .Range("F" & c.Row)
.Range("F" & maxz + 1 & ":F" & maxz + zeilen).Copy .Range("E" & maxz + 1)
End If
.Range("J2:J" & maxz + zeilen).Clear
.Range("C2:I" & maxz + zeilen).Sort key1:=.Range("I2"), key2:=.Range("H2")
End With
End Sub

Zwei Schönheitsfehler sind drin:
a) die blaue Zeile enthält unterschiedliche Blaus, die werden verhunzt und
b) die Sortierung entspricht NICHT dem Wunschergebnis, derweil *das* nämlich nicht stimmt: sortiert wird NICHT nach Test1, Test2, Test10, sondern nach Test1, Test11, Test2 - um das zu umgehen, muß man Zahlen mit führenden Nullen einsetzen...
Schöne Grüße,
Michael

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread