Sub
ButtonKlick()
Dim
WSh
As
Worksheet, iZeile
As
Long
, i&
Dim
rng
As
Range, rngtmp
As
Range
Set
WSh = ThisWorkbook.Sheets(
"Archiv"
)
iZeile = WSh.Cells(WSh.Rows.Count,
"A"
).
End
(xlUp).Row + 1
Application.EnableEvents =
False
For
Each
rng
In
Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns(
"AI"
))
If
rng.Value =
"erledigt"
Then
If
rngtmp
Is
Nothing
Then
Set
rngtmp = rng.EntireRow
Else
Set
rngtmp = Union(rngtmp, rng.EntireRow)
End
If
End
If
Next
If
Not
rngtmp
Is
Nothing
Then
rngtmp.EntireRow.Copy
WSh.Cells(iZeile,
"A"
).PasteSpecial xlPasteValues
rngtmp.EntireRow.Delete shift:=xlUp
End
If
Application.EnableEvents =
True
End
Sub