Word VBA Макросы. Автоматическое удаление строк в таблице по условию.

[Посетитель 04.04.2024]

Нужно с помощью макроса удалить во второй таблице документа строки.
Должны остаться строки, у которых в столбце 4 пусто, либо написано "Согласовано без замечаний ".

[Администратор]

Sub Macro()

    Dim Таблица As Table
    Dim i As Long
   
   
    ' Создание ссылки на вторую таблицу.
    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 Sub

[Посетитель 04.04.2024]

Ваще красота.
Спасибо огромное.
Но в первом своем сообщении забыл упомянуть еще один нюанс, которых хотелось бы тоже поправить.
Дело в том, что мой макрос по умолчанию, таки, сохраняет файл в указанное место, а когда выбираешь другой путь, то в D:/Документы он остается.
Можно поправить мой код так, чтобы файл не сохранялся до тех пор, пока в диалоговом окне не будет нажата кнопка "Сохранить"?

С учетом Вашего кода мой теперь выглядит так:

Спойлер

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

    ActiveWindow.ActivePane.View.Type = wdPrintView
    Selection.EndKey Unit:=wdStory
    Selection.TypeParagraph
    Selection.TypeText Text:="Исп. Иванов И.И., 7-42-64"
    Selection.EndKey Unit:=wdStory
    Selection.TypeParagraph
    Selection.TypeText Text:=Format(Now(), "dd/mm/yyyy") 'вставка текущей даты
   
    'Изменение шрифра и цвета для исполнителя и даты
   
    Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
    Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
    Selection.Font.Size = 14
    Selection.Font.Color = wdColorAutomatic
    Selection.EndKey Unit:=wdStory
   
    Dim Таблица As Table
    Dim i As Long
 
 
  ' Создание ссылки на вторую таблицу.
    Set Таблица = ActiveDocument.Tables(2)
 
  ' Удаление строк в таблице
    For i = Таблица.Rows.Count To 2 Step -1
        If Таблица.Cell(i, 4).Range.Text <> "Согласовано без замечаний " & Chr(13) & Chr(7) Then
            Таблица.Rows(i).Delete
        End If
    Next i

    'Сохранение файла в формате "ЛС сформирован ДД.ММ.ГГГГ в ЧЧ.ММ"
         
    ActiveDocument.SaveAs FileName:="ЛС сформирован " & Format(Date, "DD.MM.YYYY") & " в " & Format(Time, "HH.MM") & ".docx", FileFormat:=wdFormatXMLDocument
   
    'Изменение размещения папки, куда файл должен сохраняться по умолчанию
   
    ChangeFileOpenDirectory "D:\Документы\"
    Dialogs(wdDialogFileSaveAs).Show

End Sub

[свернуть]

[Администратор]

Создайте новую тему. В этой теме вы спросили, как удалить строки, а в другой теме задайте другой вопрос.

[Посетитель 04.04.2024]

Создал.
Но можно попросить еще об одной мелочи.

Если в графе "Согласование" ячейка вообще не заполнена, то эта строка тоже не должна удаляться

Я сам попытался разобраться, но не смог.
Пробовал кусок кода дублировать с заменой переменной - удаляются вообще все строки
Пробовал через "else"? Тоже не получилось

[Администратор]

Sub Macro()

    Dim Таблица As Table
    Dim i As Long
   
   
    ' Создание ссылки на вторую таблицу.
    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 Sub

[Посетитель 04.04.2024]

Спасибо

[Посетитель 04.04.2024]

Не учел один момент.
Иногда SAP выгружает файл без таблицы.
В таких случаях макрос, естественно начинает ругаться на строку "Set Таблица = ActiveDocument.Tables(2)" и не выполняет форматирование, которое по идее должно обрабатываться раньше блоком:
Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
    Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
    Selection.Font.Size = 14
    Selection.Font.Color = wdColorAutomatic
    Selection.EndKey Unit:=wdStory
(файл прилагается) и уж тем более не выполняет команды, которые идут после этого блока:

Спойлер

Dim Таблица As Table
    Dim i As Long
 
  ' Создание ссылки на вторую таблицу.
    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

[свернуть]

Прошу добавить строки кода, которые при отсутствии таблицы после слов "ЛИСТ СОГЛАСОВАНИЯ" отрабатывали бы все команды, предусмотренные макросом:

Спойлер

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

    ActiveWindow.ActivePane.View.Type = wdPrintView
    Selection.EndKey Unit:=wdStory
    Selection.TypeParagraph
    Selection.TypeText Text:="Исп. Иванов И.И., 000-00-00" 'заменить на свои ФИО и телефон (в кавычках)
    Selection.EndKey Unit:=wdStory
    Selection.TypeParagraph
    Selection.TypeText Text:=Format(Now(), "dd/mm/yyyy") 'вставка текущей даты
   
    'Изменение шрифра и цвета для исполнителя и даты
   
    Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
    Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
    Selection.Font.Size = 14
    Selection.Font.Color = wdColorAutomatic
    Selection.EndKey Unit:=wdStory
   
    Dim Таблица As Table
    Dim i As Long
 
  ' Создание ссылки на вторую таблицу.
    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
     
    'Сохранение файла в формате "ЛС сформирован ДД.ММ.ГГГГ в ЧЧ.ММ"
         
    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

[свернуть]

[ФАЙЛЫ ВАШИ ПОЛУЧЕНЫ - НЕТ НЕОБХОДИМОСТИ ВЫКЛАДЫВАТЬ ИХ ПОВТОРНО]

[Администратор]

Sub Macro()

    Dim Таблица As Table
    Dim i As Long
 
 
    ' Удаление строк во второй таблице.
        ' Пустые строки не надо удалять.
    ' Если в документе есть две и более таблицы.
        ' В документе может не быть таблиц.
    If ActiveDocument.Tables.Count >= 2 Then
       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
   
End Sub

[Посетитель 04.04.2024]

Файл был приложен для сравнения.

Если правильно, то Исполнитель и дата должны быть выполнены "таймс нью роман" и выровнены по левому краю. Тут я сам разобрался и поправил код. Но не пойму почему если вторая таблица есть, то Selection.TypeParagraph выполняется и дополнительный отступ перед исполнителем появляется, а вот если таблицы нет, то и дополнительного отступа нет

[Администратор]

Создайте новую тему и в ней поясните проблему. В этой теме обсуждается только удаление строк в таблице.