' программа сдвига диапазонов с данными согласно текущей дате
Sub Moving()
'
' 1. ПОИСК ЛИСТА С РАСПИСАНИЕМ
' Чтобы отвязаться от имени листа (пользователь может его переименовать по собственному усмотрению)
'   делаем привязку к листу по признаку нахождения определенной информации в определенной ячейке такого листа
' в данном случае это ячейка А1 и содержимое "."
Dim objSheet As Worksheet, SheetName As String
         For Each objSheet In ThisWorkbook.Sheets
             If objSheet.Range("A1") = "." Then SheetName = objSheet.Name: GoTo Yes
         Next
         MsgBox "Не найдена страница с расписанием по метке '.' в ячейке А1"
         Exit Sub    ' не нашли страницу, выходим
' Нашли, что искали. Работаем дальше
Yes:
         Sheets(SheetName).Select
'
' 2. присваивание диапазонов переменным
Dim today As Date, i As Long
' прошлая "сегодняшняя" дата на время последнего сохранения файла в блоке "сегодня"
         today = Range("H1") ' в today лежит бывшее "сегодня"
' назначает переменным диапазоны
         Set today_1 = Sheets(SheetName).Range("C4:G20") ' вчера
         Set today0 = Sheets(SheetName).Range("H4:L20")  ' сегодня
         Set today1 = Sheets(SheetName).Range("M4:Q20")  ' завтра
         Set today2 = Sheets(SheetName).Range("R4:V20")  ' и т.д.
         Set today3 = Sheets(SheetName).Range("W4:AA20")
         Set today4 = Sheets(SheetName).Range("AB4:AF20")
'
' 3. Проверяем, прошлая дата "из будущего"?
         If today >= Date Then GoTo ОКеу ' да, из будущего, т.к. бывшее "сегодня" ещ§ не наступило
'
' 4. "замораживаем" вывод на экран, чтобы не мельтишило и не тормозило
         Application.ScreenUpdating = False
'
' очищаем, если сдвигать бессмысленно
         If Date - today > 7 Then
             today_1.ClearContents
             today0.ClearContents
             today1.ClearContents
             today2.ClearContents
             today3.ClearContents
             today4.ClearContents
             GoTo ОКеу:
         End If
'
' сдвигаем столько раз, какова разница между датой прежних данных и текущей датой
         For i = 1 To Date - today
             If Weekday(today, 2) < 5 Then
                 today0.Copy (today_1)
                 today1.Copy (today0)
                 today2.Copy (today1)
                 today3.Copy (today2)
                 today4.Copy (today3)
                 today4.ClearContents
             End If
             If Weekday(today, 2) = 5 Then
                 today1.Copy (today_1)
                 today0.ClearContents
             End If
             If Weekday(today, 2) = 6 Then
                 today0.ClearContents
             End If
             If Weekday(today, 2) = 7 Then
                 today1.Copy (today0)
                 today2.Copy (today1)
                 today3.Copy (today2)
                 today4.Copy (today3)
                 today4.ClearContents
             End If
             today = today + 1
         Next i
' устанавливаем текущую дату
ОКеу:
         Range("H1") = Date
' теперь можно вывести результат
         Application.ScreenUpdating = True
End Sub