|
Hallo,
so:
Sub EintraegeKopieren()
Dim ws As Worksheet
Dim wsTarget As Worksheet
Dim rngSource As Range
Dim i As Integer, j As Integer
Dim lr As Long, lrTarget As Long, col As Long
Set wsTarget = Sheets("Gesamtliste")
For i = 3 To 53
Set ws = Sheets(i)
'Letzte Zeile im Sheet(Gesamtliste) ermitteln
lrTarget = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row
With ws
'Letzte Zeile im jeweiligen Sheet ermitteln
lr = .Cells(Rows.Count, 1).End(xlUp).Row
'Prüfen, ob ab Zeile 20 Werte im jeweiligen Sheet stehen
If lr >= 20 Then
'Durchlauf aller Zeilen ab Zeile 20 bis zur letzten verwendeten Zeile
For j = 20 To lr
'aktuelle Zeile kopieren
Set rngSource = .Range(.Cells(j, 1), .Cells(j, 18))
'Einträge kopieren und am Ende in Sheet("Gesamtliste") einfügen
If rngSource.Cells(1, 13).Value = "nein" Then
rngSource.Copy Destination:=wsTarget.Cells(lrTarget + 1, 1)
lrTarget = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row
End If
Next j
End If
End With
Next i
End Sub
Gruß,
|