Dim tb1 As Table
 Dim i As Integer
 Dim str1 As String
 Dim a As String
 Dim m As String
 Dim str As String
 Dim pyt As String
 Dim pyt1 As String
 Dim mes As String
 Dim pt As Variant
 Dim pt1 As Variant
 
m = InputBox("Введите число, месяц и год в формате 01.07.2009", "ввод текущей даты")
f = Len(m)
If f < 6 Then
      MsgBox "Нулевые значения недопустимы", vbCritical, "Ошибка ввода"
   Exit Sub
End If
pt = DatePart("d", m, Now)
Debug.Print pt
pt1 = DatePart("M", m, Now)
 Selection.Font.Bold = wdToggle
     Selection.Font.Size = 16
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
     Selection.Font.Bold = wdToggle
Selection.TypeText Text:="Список заданий" & vbCr & "назначенных на" & vbCr & "на " & m
     Selection.TypeParagraph
    
If pt1 = 1 Then
        mes = "январь"
End If
If pt1 = 2 Then
        mes = "февраль"
End If
If pt1 = 3 Then
        mes = "март"
End If
If pt1 = 4 Then
        mes = "апрель"
End If
If pt1 = 5 Then
        mes = "май"
 End If
If pt1 = 6 Then
        mes = "июнь"
End If
If pt1 = 7 Then
        mes = "июль"
End If
If pt1 = 8 Then
         mes = "август"
End If
If pt1 = 9 Then
         mes = "сентябрь"
End If
If pt1 = 10 Then
          mes = "октябрь"
End If
If pt1 = 11 Then
          mes = "ноябрь"
End If
If pt1 = 12 Then
          mes = "декабрь"
End If

pyt = "\\ххх.ххх.х.х\задания\" & mes
Debug.Print pyt
pyt1 = pyt & "\*.*"
Debug.Print pyt1
'__________________________________________________________________________
  
    str = Dir(pyt1)
     Debug.Print str
On Error GoTo обработка
   ChangeFileOpenDirectory pyt
   Documents.Open FileName:=str, _
        ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
        PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
        WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
        wdOpenFormatAuto
  Set tb1 = ActiveDocument.Tables(1)
  'Selection.Tables(1).Select
  'Selection.Rows.AllowBreakAcrossPages = False
  'ActiveDocument.Save
  tb1.Cell(1, 2).Select
  Selection.MoveRight unit:=wdCharacter, Count:=1, Extend:=wdExtend
  Selection.Copy
      
     Windows("spisok.doc").Activate 'На этой строке макрос перестает работать и переходит в конец 
  Selection.PasteAndFormat (wdPasteDefault)
  Selection.MoveUp unit:=wdLine, Count:=1
  Selection.Tables(1).Select
           Selection.Rows.ConvertToText Separator:=wdSeparateByDefaultListSeparator, _
        NestedTables:=True
  Selection.MoveDown unit:=wdLine, Count:=1
         
     Windows(str).Activate

Select Case Err.Number
Case Is = 4198
Exit Sub
End Select
Select Case Err.Number
Case Is = 4605
MsgBox "Введены несуществующие значения. Начните сначала", vbCritical, "Ошибка ввода"
 ActiveDocument.Close
Exit Sub
End Select
  
End Sub