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

[Semen90]

На большом документе Word просто отрубился на 50 минуте, исходя и прочитанного текста макроса у меня возник вопрос, а как можно поставить диапазон обработки, то есть со страницы такой то по такую? Так как документ весь табличный и примерно половина его не требует такой обработки. Заранее прошу прощения за назойливость. Есть конечно выход из положения, взять требуемые страницы вставить в новый файл - обработать и вернуть в исходный, так, что если Вам будет сложно подсказать, то именно так и поступлю

[viter.alex]

Думаю, что так должно работать. Выделите диапазон, в котором нужно обработать таблицы и вперед. Если всё же нужно по страницам, тоже несложно, но чуть позже. Бегу домой

Sub DeleteEmptyRows()

  On Error Resume Next
  
  Dim oSelRng As Range 'Область из которой обрабатывать таблицы
  Dim oTbl As Table 'Текущая таблица
  Dim oCell As Cell 'Ячейка в таблице
  Dim oRowRng As Range 'Диапазон для строки
  Dim iStart As Long 'Начало первой пустой ячейки в строке
  Dim iEnd As Long 'Конец последней пустой ячейки в строке
  Dim i As Long 'Счетчик строк в таблице
  Dim j As Long 'Счетчик таблиц
  Dim sEmptyString As String 'Служебная строка
  
  Set oSelRng = Selection.Range 'Запоминаем диапазон выделения
  'Перебираем таблицы в выделении, начиная с конца
  For j = oSelRng.Tables.Count To 1 Step -1
    Set oTbl = oDocCurr.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 ' то ячейки удаляем
              oDocCurr.Save 'документ сохраняем
            End If
          End If
        Else: Err.Clear 'очищаем ошибку
        End If
      End If
    Next i
  Next j
End Sub

[Semen90]

Ну что ж Вы помогли мне опровергнуть песню следующего содержания - "Кто людям помогает, тот тратит время зря, хорошими делами прославиться нельзя...."

[Semen90]

Упс в данной интрепитации Word почему то покидает меня вплодь до перезагруза всего компа вцелом

[viter.alex]

Виноват, переменную для документа убрал, а в теле макроса она осталась, а поскольку On Error Resume Next позволяет игнорировать ошибки, то Word и подвисал, пытаясь обратиться к содержимому несуществующей переменной.

Sub DeleteEmptyRows()

  On Error Resume Next
  
  Dim oSelRng As Range 'Область из которой обрабатывать таблицы
  Dim oTbl As Table 'Текущая таблица
  Dim oCell As Cell 'Ячейка в таблице
  Dim oRowRng As Range 'Диапазон для строки
  Dim iStart As Long 'Начало первой пустой ячейки в строке
  Dim iEnd As Long 'Конец последней пустой ячейки в строке
  Dim i As Long 'Счетчик строк в таблице
  Dim j As Long 'Счетчик таблиц
  Dim sEmptyString As String 'Служебная строка
  
  Set oSelRng = Selection.Range 'Запоминаем диапазон выделения
  'Перебираем таблицы в выделении, начиная с конца
  For j = oSelRng.Tables.Count To 1 Step -1
    Set oTbl = oSelRng.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 = oSelRange.Document.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
  Next j
End Sub

[Semen90]

Как не странно но первый вариант оказался самы живучий, просто вырезаю нужный фрагмент для обработки вствляю в другой файл обрабатываю и возращаю на место

[viter.alex]

Совсем не странно, первый вариант я тестировал, а последующие — умозрительные, дома некогда тестировать: ребенок

[Semen90]

Удачи в воспитании

[tolikman]

прошу удалить это сообщение, нечайно нажал на ентер...

[tolikman]

Попробуйте добавить к первому коду Viter.Alex'a процедуру "DoEvents":

.... первый вариант кода ....
        Else: Err.Clear 'очищаем ошибку
        End If
      End If
    Next i
    DoEvents
  Next j
End Sub

Это позволит Word'у после проверки каждой таблицы, говорить Вашей системе о том что его не заглючило, а для пущей комфортности прямо перед DoEvents можно добавить еще:

Application.StatusBar = "Обрботано: " & Cint((oDocCurr.Tables.Count - j)/oDocCurr.Tables.Count*100) & "%"

Вы будете знать сколько таблиц (в % от общего количества) обработано, отображаться будет в Worde в низу, в 2007 - по середине, в остальных версиях тоже где-то там же...
итого:

Sub DeleteEmptyRows()

  On Error Resume Next
  
  Dim oDocCurr As Document 'Рабочий документ
  Dim oTbl As Table 'Текущая таблица
  Dim oCell As Cell 'Ячейка в таблице
  Dim oRowRng As Range 'Диапазон для строки
  Dim iStart As Long 'Начало первой пустой ячейки в строке
  Dim iEnd As Long 'Конец последней пустой ячейки в строке
  Dim i As Long 'Счетчик строк в таблице
  Dim j As Long 'Счетчик таблиц
  Dim sEmptyString As String 'Служебная строка
  
  Set oDocCurr = ActiveDocument 'Запоминаем активный документ
  'Перебираем таблицы в документе, начиная с конца документа
  For j = oDocCurr.Tables.Count To 1 Step -1
    Set oTbl = oDocCurr.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 ' то ячейки удаляем
              oDocCurr.Save 'документ сохраняем
            End If
          End If
        Else: Err.Clear 'очищаем ошибку
        End If
      End If
    Next i
    Application.StatusBar = "Обрботано: " & Cint((oDocCurr.Tables.Count - j)/oDocCurr.Tables.Count*100) & "%" 
    DoEvents
  Next j
End Sub

Ну и если сильно захотеть можно рассчитать сколько осталось времени до завершения, приблизительно (особенно если таблицы едентичные).
Попробуй - вдруг поможет.