Удаление пустых абзацев в ячейках таблиц

[Niyetkhan]

Здравствуйте всем!

Столкнулся со следующей задачей, которую не получается решить.
В документе Word 60 из страниц встречается много таблиц. Файл прилагаю.
Проблема в том, что в большинстве ячеек этих таблиц имеются пустые абзацы перед текстом и после него (т.е. в верху и внизу ячеек).
Надо удалить их все.
Нашел один макрос.
При запуске он работает как надо, но затем в процессе код внезапно прекращает свою работу.
Теперь вопрос:
Можно ли:
Изменить данный код так, чтобы обрабатывались все ячейки без исключения?

Sub RemoveBlankPara()

Dim aDoc As Document
Dim i As Integer, TableCount As Integer
Dim aCell As Cell
Dim var As Variant, var2 As Variant

Set aDoc = ActiveDocument
TableCount = aDoc.Tables.Count

If TableCount = 0 Then
    Exit Sub  ' no point if there are no tables
Else
    For var = 0 To TableCount
        If Selection.Information(wdWithInTable) = False Then
            Selection.GoToNext What:=wdGoToTable
        End If
        On Error Resume Next
' select each cell in current table and count paragraphs
' collapse to beginning and expand through each paragraph
' delete if paragraph = vbCr
' otherwise, collapse to end and continue
        For Each aCell In aDoc.Bookmarks("\table").Range.Cells
            aCell.Select
            i = Selection.Paragraphs.Count
            Selection.Collapse Direction:=wdCollapseStart
            For var2 = 1 To i
                Selection.Expand Unit:=wdParagraph
                If Selection.Text = vbCr Then
                    Selection.Delete
                Else
                    Selection.Collapse wdCollapseEnd
                End If
            Next
        Next aCell
        ' move out of current table
       Selection.Move Unit:=wdCharacter, Count:=1
    Next   ' goes to next table in tablecount
End If
Set aDoc = Nothing
End Sub

Буду очень признателен за все ответы.

С уважением,
Ниетхан

[Eugene-LS]

Сообщение от Niyetkhan

Изменить данный код так, чтобы обрабатывались все ячейки без исключения?

Попробуйте так:

Sub RemoveBlankParagraphs()
' Удаление пустых параграфов во всех ячейках всех таблиц документа
' https://www.programmersforum.ru/showthread.php?t=346549
' -------------------------------------------------------------------------------------------------/
Dim objDoc As Document, objRange As Range, objRangeP As Range
Dim i As Integer, TableCount As Integer
Dim objTable As Table, objCell As Cell, objParagraph As Paragraph
Dim iVal%, iParagraphsCount%, iDelCount%
On Error GoTo RemoveBlankParagraphs_Err

    Set objDoc = ActiveDocument
    TableCount = objDoc.Tables.Count

    If TableCount = 0 Then ' no point if there are no tables
        'MsgBox "This document contains no tables", vbExclamation
        MsgBox "Документ не содержит таблиц!", vbExclamation
        GoTo RemoveBlankParagraphs_End
    End If
    
    For Each objTable In objDoc.Tables
        For Each objCell In objTable.Range.Cells
            Set objRange = objCell.Range
            objRange.Collapse Direction:=wdCollapseStart
            objRange.Expand Unit:=wdParagraph
            For Each objParagraph In objRange.Paragraphs
                Set objRangeP = objParagraph.Range
                If Trim(objRangeP.Text) = vbCr Then
                    objRangeP.Delete
                    iDelCount = iDelCount + 1
                End If
            Next objParagraph
        Next objCell ' к следующей ячейке
    Next objTable    ' goes to next table

    If iDelCount > 0 Then
        MsgBox "Удалено: " & iDelCount & " пустых парагрофов в ячейках таблиц.", vbInformation, "Info"
    Else
        MsgBox "Пустых парагрофов в ячейках таблиц не найдено.", vbInformation, "Info"
    End If
    
RemoveBlankParagraphs_End:
    On Error Resume Next
    Set objRangeP = Nothing
    Set objRange = Nothing
    Set objCell = Nothing
    Set objTable = Nothing
    Set objDoc = Nothing

    Err.Clear
    Exit Sub

RemoveBlankParagraphs_Err:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Sub :" & _
        "RemoveBlankPara - ThisDocument.", vbCritical, "Error!"
    'Debug.Print "RemoveBlankParagraphs_Line: " & Erl & "."
    Err.Clear
    Resume RemoveBlankParagraphs_End
End Sub

[Niyetkhan]

Спасибо Вам большое!

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

Еще раз благодарю, выручили!

С уважением,
Ниетхан

[Eugene-LS]

Сообщение от Niyetkhan

Намного быстрее, чем предыдущий макрос.

Это за счёт отказа от переходов по тексту (aCell.Select ...)

Ниже немного доработанная версия:

Sub RemoveBlankParagraphs()
' Удаление пустых параграфов во всех ячейках всех таблиц документа
' https://www.programmersforum.ru/showthread.php?t=346549
' -------------------------------------------------------------------------------------------------/
Dim objDoc As Document, objRange As Range, objRangeP As Range
Dim objTable As Table, objCell As Cell, objParagraph As Paragraph
Dim iVal%
' -------------------------------------------------------------------------------------------------/
On Error GoTo RemoveBlankParagraphs_Err

    Set objDoc = ActiveDocument
    iVal = objDoc.Tables.Count

    If iVal = 0 Then ' no point if there are no tables
        MsgBox "Документ не содержит таблиц!", vbExclamation
        GoTo RemoveBlankParagraphs_End
    End If
    
    iVal = 0
    For Each objTable In objDoc.Tables
        For Each objCell In objTable.Range.Cells
            Set objRange = objCell.Range
            For Each objParagraph In objRange.Paragraphs
                Set objRangeP = objParagraph.Range
                If Trim(objRangeP.Text) = vbCr Then
                    objRangeP.Delete
                    iVal = iVal + 1
                End If
            Next objParagraph
        Next objCell ' к следующей ячейке
    Next objTable    ' goes to next table

    If iVal > 0 Then
        MsgBox "Удалено: " & iVal & " пустых парагрофов в ячейках таблиц.", vbInformation, "Info"
    Else
        MsgBox "Пустых парагрофов в ячейках таблиц не найдено.", vbInformation, "Info"
    End If
    
RemoveBlankParagraphs_End:
    On Error Resume Next
    Set objParagraph = Nothing
    Set objRangeP = Nothing
    Set objRange = Nothing
    Set objCell = Nothing
    Set objTable = Nothing
    Set objDoc = Nothing

    Err.Clear
    Exit Sub

RemoveBlankParagraphs_Err:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Sub :" & _
        "RemoveBlankParagraphs - ThisDocument.", vbCritical, "Error!"
    Err.Clear
    Resume RemoveBlankParagraphs_End
End Sub

Успехов!