Sub aaa()
    Dim y1 As Long
    Dim y2 As Long
    Dim dogovor As String
    Dim a As Variant
    For y1 = 3 To Cells(Rows.Count, 1).End(xlUp).Row
        dogovor = Cells(y1, 1).Value
        If dogovor <> "" Then
            y2 = y1 + 1
            Do
                If Cells(y2, 2).Value = "" Then Exit Do
                y2 = y2 + 1
            Loop
            If y2 = y1 + 1 Then
                ReDim a(1 To 1, 1 To 1)
                a(1, 1) = Cells(y2, 2)
            Else
                a = Range(Cells(y1 + 1, 2), Cells(y2, 2))
            End If
            sheet_job dogovor, a
            Erase a
        End If
    Next
End Sub

Sub sheet_job(dogovor_name As String, a As Variant)
    Dim sh As Worksheet
    Set sh = ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count))
    sh.Name = dogovor_name
    sh.Cells(1, 1).Value = dogovor_name
    sh.Columns(1).ColumnWidth = 10
    Dim y As Long
    Dim i As Long
    For y = 1 To UBound(a, 1)
        i = InStrRev(a(y, 1), " ")
        If i > 0 Then
            sh.Cells(1 + y, 1).Value = CDate(Mid(a(y, 1), i + 1))
        End If
    Next
End Sub