Option
Explicit
Sub
Schritt10()
Dim
w
As
Long
Dim
q
As
Long
With
Worksheets(
"Sheet 1"
)
Dim
dtm
As
Date
dtm = Now()
For
w = 2
To
502
For
q = 2
To
502
If
.Cells(w,
"AI"
) = .Cells(q,
"BE"
) _
And
.Cells(w,
"AN"
) < .Cells(q,
"BJ"
) _
Then
.Range(.Cells(w,
"AQ"
), .Cells(w,
"AZ"
)) = .Range(.Cells(q,
"BC"
), .Cells(q,
"BL"
))
.Cells(q,
"CA"
) = 1
End
If
Next
If
DateDiff(
"s"
, dtm, Now()) > 2
Then
dtm = Now()
DoEvents
End
If
Next
End
With
Call
MsgBox(
"Fertig."
, vbInformation)
End
Sub