Sub Перенести_в_A()
    
    Dim arr(), arrWeekDays(), var
    Dim lr As Long, i As Long, ii As Long
    
    Application.ScreenUpdating = False
    
    arrWeekDays() = Array("понедельник", "вторник", "среда", "четверг", "пятница", "суббота", "воскресенье")
    
    lr = Cells(Rows.Count, "B").End(xlUp).Row
    arr() = Range("B1:B" & lr).Value
    
    For i = 1 To UBound(arr)
        var = Split(arr(i, 1), " ")
        If UBound(var) = 1 Then
            var(0) = LCase(var(0))
            For ii = 0 To UBound(arrWeekDays)
                If var(0) = arrWeekDays(ii) Then
                    If IsDate(var(1)) Then
                        Cells(i, "A").Value = arr(i, 1)
                        Cells(i, "B").ClearContents
                    End If
                    Exit For
                End If
            Next
        End If
    Next
    
    Application.ScreenUpdating = True
    
End Sub