|
dafür das es dringend ist ,hast du 5 tage Zeit verstreichen lassen.
Hier ein Versuch.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Dim sName$, i&
If Intersect(Target, Range("I:I")) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
Select Case Target.Value
Case "Rechnung erstellt", "Rechnung erstellt + Abschluss"
Application.EnableEvents = False
sName = Cells(Target.Row, "S").Value
Target.Offset(0, 1) = Format(Now(), "DD.MM.YY")
Set rng = Intersect(Range("A:J"), Target.EntireRow)
With Worksheets("Archiv")
nextrow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Cells(nextrow, 1).Resize(1, rng.Columns.Count).Value = rng.Value
End With
Set rng = Nothing
For i = 2 To Cells(Rows.Count, "S").End(xlUp).Row
If Cells(i, "S") = sName Then
If rng Is Nothing Then
Set rng = Cells(i, "I").Resize(1, 2)
Else
Set rng = Union(rng, Cells(i, "I").Resize(1, 2))
End If
End If
Next
If Not rng Is Nothing Then rng.ClearContents
Application.EnableEvents = True
Case Else
End Select
End Sub
|