Sub
Tast()
Const
C_ur
As
String
=
"B4:J40"
Dim
ur
As
Range, ac
As
Range, ar
As
Range, ae
As
Range
Set
ur = Range(C_ur)
Set
ac = ActiveCell
For
Each
ar
In
ur.Rows
If
Not
Intersect(ac, ar)
Is
Nothing
Then
With
ar
On
Error
Resume
Next
Set
ae = Union(ac, .Cells(1).Resize(, 4), .Cells(7).Resize(, 2)).SpecialCells(xlCellTypeBlanks)
If
Err.Number
Then
If
MsgBox(
"Willst du die Zeile wirklich ins Archiv löschen?"
, vbYesNo,
"Tages-Sonderaufgaben "
) <> vbYes
Then
Exit
Sub
Call
MsgBox(
"ausgewählte Zeile verschoben"
& vbLf & _
"und Bereich aufgefüllt"
, vbExclamation,
"Fertig"
)
Else
Call
MsgBox(
"Fehler"
& vbLf & _
"Bitte eine ausgefüllte Zelle wählen"
& vbLf & _
"oder leere Pflichtfelder gefunden"
, vbExclamation,
"Abbruch"
)
End
If
On
Error
GoTo
0
End
With
Exit
For
End
If
Next
ar
End
Sub