Sub Copy_week()    'копирование расписаний

    Dim wd As Integer, TableName As String, Rng As Range, Sh1 As Worksheet, Sh As Worksheet

    Set Sh = ThisWorkbook.Worksheets("ПОГРУЗКА")
    Set Sh1 = ThisWorkbook.Worksheets("РАСПИСАНИЯ")
    Monts = Array("", "УТ_ПОНЕДЕЛЬНИК", "УТ_ВТОРНИК", "УТ_СРЕДА", _
                  "УТ_ЧЕТВЕРГ", "УТ_ПЯТНИЦА", "УТ_СУББОТА", "УТ_ВОСКРЕСЕНЬЕ")
    wd = Weekday(Date, vbMonday)
    TableName = Monts(wd)
    Set Rng = Sh1.Range(TableName)
    Set LB = Sh.ListObjects(1)
    LastRow = LB.Range.Row + LB.Range.Rows.Count - 1
    If Sh.Range("G" & LastRow) <> "" Then
        LastRow = LastRow + 1
    End If
    rc = Rng.Rows.Count
    Rng.Copy Sh.Range("G" & LastRow)
    Sh.Range("B" & LastRow).Resize(rc, 1) = Date
    MsgBox ("РАСПИСАНИЯ ДОБАВЛЕНЫ УСПЕШНО!")

End Sub