Форум по VBA и MS Office

Sub ЛС()
    ' Включение режима разметки страницы и переход в конец документа

    ActiveWindow.ActivePane.View.Type = wdPrintView
    Selection.EndKey Unit:=wdStory
    Selection.TypeParagraph
    Selection.ParagraphFormat.SpaceBefore = 18
    Selection.TypeText Text:="Исп. *****В.В., **-**-**" 'заменить на свои ФИО и телефон (в кавычках)
    Selection.EndKey Unit:=wdStory
    Selection.TypeParagraph
    Selection.TypeText Text:=Format(Now(), "dd/mm/yyyy") 'вставка текущей даты
    WordBasic.OpenOrCloseParaAbove
   
    'Изменение шрифта и цвета для исполнителя и даты
   
    Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
    Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
    Selection.Font.Size = 14
    Selection.Font.Color = wdColorAutomatic
    Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
    Selection.Font.Name = "Times New Roman"
    Selection.EndKey Unit:=wdStory
   
    Dim Таблица As Table
    Dim i As Long
 
    ' Удаление строк во второй таблице, не затрагивая пустые, если в документе есть две и более таблицы.
    ' В документе может не быть таблиц.
    If ActiveDocument.Tables.Count >= 2 Then
      Selection.MoveUp Count:=1
      Selection.HomeKey
      Selection.TypeBackspace
      Set Таблица = ActiveDocument.Tables(2)
      For i = Таблица.Rows.Count To 2 Step -1
          If Таблица.Cell(i, 4).Range.Text = Chr(13) & Chr(7) Then
          ElseIf Таблица.Cell(i, 4).Range.Text <> "Согласовано без замечаний " & Chr(13) & Chr(7) Then
                  Таблица.Rows(i).Delete
          End If
      Next i
    End If
   
    'Сохранение файла в формате "ЛС сформирован ДД.ММ.ГГГГ в ЧЧ.ММ"
         
    Dim Fn As String
     
    With Application.FileDialog(msoFileDialogSaveAs)
        .Title = "Сохранить как"
        .InitialFileName = "D:\Документы\ЛС сформирован " & Format(Date, "DD.MM.YYYY") & " в " & Format(Time, "HH.MM")
        If .Show = False Then
            Exit Sub
        End If
        Fn = .SelectedItems(1)
    End With
      ActiveDocument.SaveAs FileName:=Fn, FileFormat:=wdFormatXMLDocument
 
  End Sub