Option Explicit
Private rPlan As Range
Private rVann As Range
Private rDays As Range
Private dtStart As Date

Sub План_А()
    InitRange
    Dim yPlan As Long, yVann As Long, xVann As Long
    
    For yPlan = 1 To rPlan.Rows.Count
        Do
            'If yPlan > rPlan.Rows.Count Then yPlan = 1
            If rPlan.Cells(yPlan, 4).Value > rPlan.Cells(yPlan, 5).Value Then
                yVann = FindVann(xVann)
    '            If yVann > 0 Then
                    FillRow yVann, xVann, rPlan.Cells(yPlan, 3).Value, rPlan.Cells(yPlan, 1).Value
    '            End If
            Else
                Exit Do
            End If
            
            If CheckExit Then Exit Do
            DoEvents
        Loop
    Next
End Sub

Sub План_Б()
    InitRange
    
    Dim yPlan As Long, yVann As Long, xVann As Long
    
    Do
        yPlan = yPlan + 1
        If yPlan > rPlan.Rows.Count Then yPlan = 1
        If rPlan.Cells(yPlan, 4).Value > rPlan.Cells(yPlan, 5).Value Then
            yVann = FindVann(xVann)
'            If yVann > 0 Then
                FillRow yVann, xVann, rPlan.Cells(yPlan, 3).Value, rPlan.Cells(yPlan, 1).Value
'            End If
        End If
        
        If CheckExit Then Exit Do
        DoEvents
    Loop
End Sub

Private Sub InitRange()
    Dim sh As Worksheet
    Set sh = ActiveSheet
    Set rPlan = sh.Range("планы")
    Set rVann = sh.Range("ванны")
    Set rDays = sh.Range("дни")
    dtStart = Now
End Sub

Private Function CheckExit() As Boolean
    If dtStart < Now - TimeSerial(0, 1, 0) Then
        CheckExit = True
        Exit Function
    End If
    
    rPlan.Calculate
    
    Dim yPlan As Long
    For yPlan = 1 To rPlan.Rows.Count
        If rPlan.Cells(yPlan, 4).Value > rPlan.Cells(yPlan, 5).Value Then Exit Function
    Next
    CheckExit = True
End Function

Private Sub FillRow(yVann As Long, xVann As Long, nDays As Long, marka As String)
    Dim aOut As Variant
    ReDim aOut(1 To 1, 1 To nDays)
    Dim xa As Long
    For xa = 1 To nDays - 1
        aOut(1, xa) = xa
    Next
    aOut(1, xa) = marka
    
    Dim rOut As Range
    Set rOut = Intersect(rVann.Cells(yVann, 1).EntireRow, rDays.Cells(1, xVann).EntireColumn).Resize(1, nDays)
    'Application.Goto rOut
    rOut.Value = aOut
    rOut.Interior.Pattern = xlNone
    rOut.Cells(1, nDays).Interior.Color = RGB(255, 255, 0)
    
End Sub

Private Function FindVann(xVann As Long) As Long
    Dim yVann As Long
    For yVann = 1 To rVann.Parent.Rows.Count
        For xVann = rDays.Columns.Count - 1 To 1 Step -1
            If Not IsEmpty(rVann.Cells(yVann, xVann + 1)) Then
                If IsEmpty(rVann.Cells(yVann, xVann + 2)) Then
                    xVann = xVann + 1
                    FindVann = yVann
                    Exit Function
                End If
            End If
        Next
        If IsEmpty(rVann.Cells(yVann, 2)) Then
            xVann = 1
            FindVann = yVann
            Exit Function
        End If
    Next
End Function

Sub Очистить()
    InitRange
    
    Dim rr As Range
    Set rr = Intersect(rVann.EntireRow, rDays.EntireColumn)
    Set rr = rr.Resize(, rr.Columns.Count + 20)
    
    rr.ClearContents
    rr.Interior.Pattern = xlNone
End Sub