Удаление пустых строк в таблице

[Semen90]

Запустил тестировать так же на большом документе, но не уверен за результат, так старый ворд полетел, а тот, что сейчас установлен, как то не адекватно установился. Завтра точне сегодня после обеда смогу сказать точно как работает макрос на больших объемах

[tolikman]

Работоспособность макросов редко нарушается после неудачной инсталяции офиса, обычно накрывается пользовательский интерфейс.

[Semen90]

Спасибо! Удачное решение, а то и не знаешь толи висит толи работает
И все таки так и остался вопрос по поводу диапазона обработки как указать диапазон в страницах, с выделением как выяснилось работает не очень удачно. Извените за назойливость

[viter.alex]

Попробуй такой вариант. Внёс изменения, которые предложил tolikman. Пользователю предлагается указать номера страниц, на которых обрабатывать таблицы. Код без подсветки потому, что иначе не влезет в сообщение.

Private Declare Function GetTickCount Lib "kernel32" () As Long

Sub DeleteEmptyRows()

  On Error Resume Next
  
  Dim oDocCurr As Document 'Рабочий документ
  Dim oSrchRng As Range 'Диапазон, в котором искать страницы
  Dim oTbl As Table 'Текущая таблица
  Dim oCell As Cell 'Ячейка в таблице
  Dim nTblsCount 'Количество таблиц в диапазоне
  Dim nStartPage As Long, nEndPage As Long 'Номер первой и последней страницы, которые нужно просматривать
  Dim nDocPagesCount 'количество страниц в документе
  Dim sInputStr As String 'Строка для ввода номеров страниц
  Dim oRowRng As Range 'Диапазон для строки
  Dim iStart As Long 'Начало первой пустой ячейки в строке
  Dim iEnd As Long 'Конец последней пустой ячейки в строке
  Dim i As Long 'Счетчик строк в таблице
  Dim j As Long 'Счетчик таблиц
  Dim StartTime As Long 'Таймер
  Dim sEmptyString As String 'Служебная строка
  
  Set oDocCurr = ActiveDocument 'Запоминаем активный документ
  nDocPagesCount = oDocCurr.Range.ComputeStatistics(wdStatisticPages)
  'Запрос номеров страниц
  sInputStr = InputBox("Укажите диапазон страниц, в котором обрабатывать таблицы", "Удаление пустых строк", _
                    "1-" & nDocPagesCount)
  
  If Len(sInputStr) <> 0 Then
    'Извлекаем номера страниц из строки
    nStartPage = CLng(Mid(sInputStr, 1, InStr(sInputStr, "-") - 1))
    nEndPage = CLng(Mid(sInputStr, InStr(sInputStr, "-") + 1))
  Else: Exit Sub
  End If
  'Если номер начальной страницы меньше единицы, или номер конечной страницы больше количества _
  страниц в документе или равен нулю, или номер начальной страницы больше номера конечной, то прекращаем выполнение макроса
  If nStartPage < 1 Or _
     nEndPage > nDocPagesCount Or _
     nStartPage > nEndPage or _
     nednThen
    Exit Sub
  End If
  
  'Запоминаем диапазон нужных страниц
  Set oSrchRng = oDocCurr.Range.GoTo(wdGoToPage, wdGoToAbsolute, nStartPage)
  oSrchRng.SetRange oSrchRng.Start, oDocCurr.Range.GoTo(wdGoToPage, wdGoToAbsolute, nEndPage + 1).Start
  
  nTblsCount = oSrchRng.Tables.Count
  
  StartTime = GetTickCount 'Запоминаем момент начала цикла
  'Перебираем таблицы в документе, начиная с конца документа
  For j = nTblsCount To 1 Step -1
    Set oTbl = oSrchRng.Tables(j) 'Запоминаем таблицу
    'Перебираем ячейки в первом столбце
    For i = oTbl.Rows.Count To 1 Step -1
      If Len(oTbl.Cell(i, 1).Range.Text) = 2 Then 'Если ячейка пустая, т.е. содержит только конец абзаца и конец ячейки
        If Err.Number <> 5941 Then 'Если такая ячейка существует
          Set oCell = oTbl.Cell(i, 1) 'Запоминаем первую ячейку в строке
          If Not oCell Is Nothing Then 'Если ячейка запомниалась
            iStart = oCell.Range.Start 'Запоминаем ее начало
            Do While Len(oCell.Next.Range.Text) = 2 'Теперь ищем последнюю пустую ячейку в этой же строке
              iEnd = oCell.Next.Range.End 'Запоминаем ее конец
              Set oCell = oCell.Next
            Loop
            Set oRowRng = oDocCurr.Range(iStart, iEnd) 'Запоминаем диапазон от начала первой пустой ячейки до конца последней
            'Удаляем из строки знаки абзаца и конца ячейки
            sEmptyString = Replace(oRowRng.Text, ChrW(13) & ChrW(7), "")
            If Len(sEmptyString) = 0 Then 'Если строка пустая,
              oRowRng.Cells.Delete ' то ячейки удаляем
            End If
          End If
        Else: Err.Clear 'очищаем ошибку, если ячейки не было
        End If
      End If
    Next i 'конец цикла перебора строк
    Application.StatusBar = "Обработано " & nTblsCount - j + 1 & " таблиц. Прошло " & FormatNumber((StartTime - GetTickCount) / 1000, 1, groupdigits:=vbTrue) & " сек."
    DoEvents
  Next j 'конец цикла перебора таблиц
End Sub

[drosselino]

Всем привет! Огромное спасибо за тему. У меня не все работает стабильно, но один из кодов удалось "оптимизировать" под свои нужды). Но есть проблема. Подскажите, пожауйста, как поправить код, чтобы макрос не удалял пустые ячейки в начале строки? Дело в том, что он не понимает, что строка не закончилась и удаляет эти ячейки (см. приложенный скрин).
С полностью пустыми строками проблем нет - сносит базжалостно.
Заранее спасибо
https://dropmefiles.com/hXGy4