VBA - Schleife mehrere Bedingungen, Zeile kopieren

Hallo,
ich habe eine Datenliste (zip-File), die mit einer Schleife nach verschiedenen Bedingungen durchsucht werden soll.
Dabei können die Variablen "Fix_E" (Spalte B) und "TZ_E" (Spalte E)folgende Werte annehmen:
Dim Fix_E(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 21, 28)
Dim TZ_E(0, 1, 2, 3, 4, 5, 6, 7, 14, 21, 28)

Für jeden Fix_E Wert sollen nacheinander die TZ_E Daten durchlaufen werden und für jeden Schritt in Spalte J (Liefererfüllung) geprüft werden, ob der Wert größer oder gleich 98% ist. Ist dies der Fall, soll der jeweils kleinste Wert (also jener, ab dem das Kriterium 98% zum ersten Mal erfüllt ist) in ein anderes Blatt gespeichert werden.
https://www.herber.de/bbs/user/26233.zip
Vielen Dank für jede Idee.
Gruß Christoph

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Christoph,
anbei ein Lösungsansatz:
Option Explicit


Sub uebertrag()
Dim s As Integer
Dim arr As Variant
Worksheets.Application.ScreenUpdating = False
For s = 2 To Worksheets("Tabelle1").Range("A65536").End(xlUp).Row
If Worksheets("Tabelle1").Cells(s, 10).Value >= 0.98 Then
arr = Worksheets("Tabelle1").Range("A" & s, "O" & s)
Worksheets("Ergebnis").Range("A" & Worksheets("Ergebnis").Range("A65536").End(xlUp).Row + 1, "O" & Worksheets("Ergebnis").Range("A65536").End(xlUp).Row + 1) = arr
Do While Worksheets("Tabelle1").Cells(s, 5) = Worksheets("Tabelle1").Cells(s - 1, 5)
s = s + 1
Loop
End If
Next s
Worksheets("Tabelle1").Range("A2:O2").Copy
Worksheets("Ergebnis").Range("A2", "O" & Worksheets("Ergebnis").Range("A65536").End(xlUp).Row).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Cells(1, 1).Select
Worksheets.Application.ScreenUpdating = True
End Sub

Er läßt sich hinsichtlich der Bearbeitungszeit sicher noch optimieren. Werde mir das morgen daraufhin noch mal ansehen.
Viele Grüße Klaus-Dieter

Online-Excel

Sub uebertrag() Dim s As Integer Dim arr As Variant Worksheets.Application.ScreenUpdating = False For s = 2 To Worksheets("Tabelle1").Range("A65536").End(xlUp).Row If Worksheets("Tabelle1").Cells(s, 10).Value >= 0.98 Then arr = Worksheets("Tabelle1").Range("A" & s, "O" & s) Worksheets("Ergebnis").Range("A" & Worksheets("Ergebnis").Range("A65536").End(xlUp).Row + 1, "O" & Worksheets("Ergebnis").Range("A65536").End(xlUp).Row + 1) = arr Do While Worksheets("Tabelle1").Cells(s, 5) = Worksheets("Tabelle1").Cells(s - 1, 5) s = s + 1 Loop End If Next s Worksheets("Tabelle1").Range("A2:O2").Copy Worksheets("Ergebnis").Range("A2", "O" & Worksheets("Ergebnis").Range("A65536").End(xlUp).Row).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Cells(1, 1).Select Worksheets.Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

VBA - Schleife mehrere Bedingungen, Zeile kopieren

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

321 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA - Schleife mehrere Bedingungen, Zeile kopieren

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

321 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread