Sub z3_b() Dim i, j, CurValue, lastrow, lastrow1, k, n, x As Integer Dim d1, d2, d3, d4 As Date Dim Name As String Dim engeneer, engeneerFound As Boolean Dim page1, page2 As Object Set page1 = Worksheets("Eoi aaao") Set page2 = Worksheets("Nienie ei?aia?ia") engeneer = False engeneerFound = False lastrow = page1.Cells(1, 1).CurrentRegion.Rows.Count lastrow1 = page2.Cells(1, 1).CurrentRegion.Rows.Count i = 2 While (i < lastrow) engeneer = False CurValue = Cells(i, 1).Value If Cells(i, 7).Value = "Eniuoaiey" Then j = i Do While Cells(j, 1) = CurValue If Cells(j, 3).Value Like "*ei?aia?*" Then engeneer = True Exit Do End If j = j + 1 Loop If Not engeneer Then 'euai ei?aia?a, eioi?ue i?e yoii naiaiaai aey aaiiie eiiaiae?iaee (o.a. ia?eiau anao aai eiiaiae?iaie ia ia?anaea?ony n aaiiie) d1 = page1.Cells(j - 1, 4) d2 = DateAdd("d", d1, page1.Cells(j - 1, 5)) For k = 2 To lastrow1 - 1 d3 = page2.Cells(k, 4) d4 = DateAdd("d", d3, page2.Cells(k, 5)) If ((d2 < d3) Or (d1 > d4)) Then For x = k + 1 To lastrow1 If page1.Cells(x, 2) = page1.Cells(k, 2) Then d3 = page2.Cells(x, 4) d4 = DateAdd("d", d3, page2.Cells(x, 5)) If ((d2 < d3) Or (d1 > d4)) Then x = x + 1 Else Exit For If x = lastrow1 Then n = k engeneerFound = True Exit For End If End If End If Next x End If If engeneerFound = True Then page1.Range(page1.Cells(j, 1), page1.Cells(lastrow, 7)).Copy page1.Range(page1.Cells(j + 1, 1), page1.Cells(lastrow + 1, 7)).PasteSpecial page2.Rows(n).Copy page1.Rows(j).PasteSpecial Cells(j, 1) = CurValue Cells(j, 4) = Cells(j - 1, 4) Cells(j, 5) = Cells(j - 1, 5) Cells(j, 7) = Cells(j - 1, 7) Rows(j).Interior.ColorIndex = 50 lastrow = lastrow + 1 End If Next k End If End If Do While Cells(i, 1) = CurValue i = i + 1 Loop Wend End Sub