Makro arbeitet nicht richtig

Sub KopierenBedingung() Dim Z1 As Integer, Z2 As Integer Z2 = 10 For Z1 = Cells(65536, 2).End(xlUp).Row To 10 Step -1 If Cells(Z1, 9) > ("602000-") Then Range(Cells(Z1, 1), Cells(Z1, 23)).Copy Destination:=Sheets("Tabelle1").Cells(Z2, 1) Z2 = Z2 + 1 Rows(Z1).ClearContents End If Next Z1 End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Josef,
dein Makro läuft schon richtig: Es kopiert die betreffenden Zeilen ab Zielzeile 10 - ob da nun schon was drin stand oder nicht.
Du willst aber wohl auch, dass in Tabelle 1 keine Zeile überschrieben wird. Also muss das Makro auch schon beim Start die erste Zielzeile hochsetzen auf die erste Zeile ab der Zeile 10, die leer ist - das macht das erste unten angehängte Makro.
Wenn die viele Zeilen hast und die Zeilen mit ... > "600200-" blockweise auftreten, lässt sich das Kopieren erheblich beschleunigen - das macht das zweite Makro unten:

Option Explicit
Sub KopierenBedingung2()
Dim Z1 As Long, Z2 As Long                    'Integer in Long geändert
If IsEmpty(Sheets("Tabelle1").Cells(10, 9)) Then
Z2 = 10
Else
Z2 = Sheets("Tabelle1").Cells(10, 9).End(xlDown).Row + 1
End If
For Z1 = Cells(65536, 2).End(xlUp).Row To 10 Step -1
If Cells(Z1, 9) > "602000-" Then
If Z2 > 65536 Then
MsgBox "In Tabelle1 ist keine Zeile mehr frei.", vbCritical
Exit Sub
End If
Range(Cells(Z1, 1), Cells(Z1, 23)).Copy Destination:=Sheets("Tabelle1").Cells(Z2, 1)
Z2 = Z2 + 1
Rows(Z1).ClearContents
End If
Next Z1
End Sub
Sub KopierenBedingung3()
Dim Z1 As Long, Z2 As Long, rg As Range       'Integer in Long geändert
If IsEmpty(Sheets("Tabelle1").Cells(10, 9)) Then
Z2 = 10
Else
Z2 = Sheets("Tabelle1").Cells(10, 9).End(xlDown).Row + 1
End If
For Z1 = Cells(65536, 2).End(xlUp).Row To 10 Step -1
If Z2 > 65536 Then
MsgBox "In Tabelle1 ist keine Zeile mehr frei.", vbCritical
Exit Sub
End If
If Cells(Z1, 9) > "602000-" Then
Set rg = Range(Cells(Z1, 1), Cells(Z1, 23))
Do While Cells(Z1 - 1, 9) > "602000-"
Z1 = Z1 - 1
If Z2 + rg.Rows.Count - 1 >= 65536 Then
MsgBox "Nicht alle Zeile wurden übertragen.", vbCritical
Exit Do
End If
Set rg = Union(rg, Range(Cells(Z1, 1), Cells(Z1, 23)))
Loop
rg.Copy Destination:=Sheets("Tabelle1").Cells(Z2, 1)
Z2 = Z2 + rg.Rows.Count
rg.EntireRow.ClearContents
End If
Next Z1
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread