Добрый день!!! искал в интернете не нашел, как в данном коде сделать так, чтобы появлялось окошко, не InputBox, а UserForm с (стандартным) календарем, (в Toolbox нашел: MonthView, DTPicker и OlkDateControl)  
 
Sub ДобавитьНовыйЛист()  
   Dim Table1 As Range, Table2 As Range  
   Dim YD As Double, TD As Double, D As Double, Reply As String, ReplyOk As Boolean, ShNewName As String  
   '  
   Set Table1 = Range([A5], [A5].End(xlDown))
   Set Table1 = Table1.Resize(, 13) ' Диапазон_вчерашней_таблицы ' <-----!!!-------  
   YD = [C1] ' Вчерашняя_Дата_сегодня '
   TD = YD + 1  
   ActiveSheet.Copy , ActiveSheet  
   Set Table2 = [A5].Resize(Table1.Rows.Count, Table1.Columns.Count) ' Диапазон_сегоднешней_таблицы '
   Application.ScreenUpdating = False  
   [C1].ClearContents ' Дата_сегодня '
   [D3] = YD ' Дата_вчера '
   With Table2  
       .Columns(5).ClearContents ' Приход '  
       .Columns(6).ClearContents ' Продано '  
       .Columns(7).ClearContents 'Другая_цена'  
       .Columns(13).ClearContents 'Примечание'  
       .Columns(4).Value = Table1.Columns(9).Value ' Остатки_вчера=Остатки_сегодня ' ' <-----!!!-------  
   End With  
   ''''ShYesterday.Shapes("Кнопка_1").Delete  
   Application.ScreenUpdating = True  
   Do  
       Reply = InputBox(String(5, vbCr) & "ВВЕДИТЕ ИМЯ НОВОГО ЛИСТА КАК ДАТУ:", "МАКСИМУМ", Format(TD, "DD.MM.YYYY"))  
       If Trim(Reply) <> "" Then  
           ReplyOk = (Reply Like "##.##.####") And IsDate(Reply)  
           If ReplyOk Then  
               D = CDate(Reply)  
               If D <= YD Then  
                   ReplyOk = False  
                   MsgBox "Текущая дата не может быть вчерашней.", , "ОШИБОЧКА"  
               Else  
                   ShNewName = Format(D, "DD.MM.YYYY")  
                   On Error Resume Next  
                   ActiveSheet.Name = ShNewName  
                   If Err = 0 Then  
                       [C1] = D ' Дата_сегодня '
                   Else  
                       Err.Clear  
                       ReplyOk = False  
                       MsgBox "Лист '" & ShNewName & "' уже существует.", vbExclamation, "ОШИБОЧКА"  
                   End If  
               End If  
           Else  
               MsgBox String$(21, " "), vbExclamation, "ОШИБОЧКА"  
           End If  
       End If  
   Loop Until ReplyOk  
   Application.GoTo [A1]
End Sub