dulitul, try this...
Code:
Option Explicit
Sub ExtractDates()
Dim i As Long
Dim LastRow As Long
Dim lRow As Long
Dim rng As Range
Dim c As Variant
Dim ebucht As Boolean
LastRow = ActiveWorkbook.ActiveSheet.Cells(65000, 14).End(xlUp).Row
Set rng = ActiveWorkbook.ActiveSheet.Range("A2:A" & LastRow)
lRow = 2
For Each c In rng
If Len("" & c.Value) = 0 Then
If IsEmpty(Range(Cells(c.Row, 1), Cells(c.Row, 14))) = False Then
If Cells(c.Row, 2) = "Upload" Then
Cells(lRow, 16).Value = Cells(c.Row, 11).Value
Else
If Cells(c.Row, 14).Value = "ebucht" Then
Cells(lRow, 17).Value = Cells(c.Row, 11).Value
ebucht = True
End If
End If
Else: Exit For
End If
Else
If c.Row > 2 Then
If ebucht = False Then
Range(Cells(lRow, 1), Cells(lRow, 14)).Interior.Color = 255
End If
End If
lRow = c.Row
ebucht = False
End If
Next c
End Sub
Bookmarks