Wenn Wert in Zelle kopiere Zeile

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub test() Dim c As Range Dim firstAddress As String Dim lngZiel As Long With Worksheets("Tabelle2") 'Zieltabellennamen anpassen lngZiel = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 Set c = Columns(1).Find("unausgefertigt", LookIn:=xlValues, lookat:=xlWhole) If Not c Is Nothing Then firstAddress = c.Address Do Rows(c.Row).Copy .Cells(lngZiel, 1) lngZiel = lngZiel + 1 Set c = Columns(1).FindNext(c) Loop While Not c Is Nothing And c.Address firstAddress End If End With End Sub

Sub test() Dim c As Range Dim firstAddress As String Dim lngZiel As Long With Worksheets("Überprüfung") 'Zieltabellennamen anpassen lngZiel = .Cells(.Rows.Count, 9).End(xlUp).Row + 1 Set c = Columns(9).Find("unausgefertigt", LookIn:=xlValues, lookat:=xlWhole) If Not c Is Nothing Then firstAddress = c.Address Do Rows(c.Row).Copy .Cells(lngZiel, 1) lngZiel = lngZiel + 1 Set c = Columns(9).FindNext(c) Loop While Not c Is Nothing And c.Address firstAddress End If End With End Sub

Sub test2() Dim lngZiel As Long Dim lngLetzte As Long Dim rngZelle As Range Dim rngBereich As Range lngLetzte = Cells(Rows.Count, 9).End(xlUp).Row Set rngBereich = Range("I1:I" & lngLetzte) With Worksheets("Überprüfung") lngZiel = .Cells(.Rows.Count, 9).End(xlUp).Row + 1 For Each rngZelle In rngBereich If rngZelle.Value = "unausgefertigt" Or _ rngZelle.Value = "" Then Rows(rngZelle.Row).Copy .Cells(lngZiel, 1) lngZiel = lngZiel + 1 End If Next End With End Sub

Hi
probier mal ob das schneller geht

Sub test2()
Dim lngZiel As Long
Dim lngLetzte As Long
Dim rngZelle As Range
Dim rngBereich As Range
Dim oldCalc
With Application
oldCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
lngLetzte = Cells(Rows.Count, 9).End(xlUp).Row
Set rngBereich = Range("I1:I" & lngLetzte)
With Worksheets("Überprüfung")
lngZiel = .Cells(.Rows.Count, 9).End(xlUp).Row + 1
For Each rngZelle In rngBereich
If rngZelle.Value = "unausgefertigt" Or _
rngZelle.Value = "" Then
Rows(rngZelle.Row).Copy .Cells(lngZiel, 1)
lngZiel = lngZiel + 1
End If
Next
End With
With Application
.CutCopyMode = False
.Calculation = oldCalc
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

MfG Tom

Sub test() ' kopiert unaufgefertigte in neues Tabellenblatt Dim c As Range Dim firstAddress As String Dim lngZiel As Long With Worksheets("Überprüfung") 'Zieltabellennamen anpassen lngZiel = .Range("I:I).SpecialCells(xlCellTypeLastCell).Row + 1 Set c = Columns(9).Find("unausgefertigt", LookIn:=xlValues, lookat:=xlWhole) If Not c Is Nothing Then firstAddress = c.Address Do Rows(c.Row).copy .Cells(lngZiel, 1) lngZiel = lngZiel + 1 Set c = Columns(9).FindNext(c) Loop While Not c Is Nothing And c.Address firstAddress End If End With End Sub

Beliebteste Forumthreads (12 Monate)

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

316 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Wenn Wert in Zelle kopiere Zeile

20 Beiträge zum Forumthread Beiträge zu diesem Forumthread

316 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread