Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Word
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 02.12.2023, 17:32   #1
Niyetkhan
Пользователь
 
Регистрация: 27.10.2016
Сообщений: 26
По умолчанию Удаление пустых абзацев в ячейках таблиц

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

Столкнулся со следующей задачей, которую не получается решить.
В документе 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

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

С уважением,
Ниетхан
Вложения
Тип файла: docx 34.docx (89.2 Кб, 2 просмотров)

Последний раз редактировалось Niyetkhan; 02.12.2023 в 17:34.
Niyetkhan вне форума Ответить с цитированием
Старый 03.12.2023, 10:02   #2
Eugene-LS
Пользователь
 
Аватар для Eugene-LS
 
Регистрация: 23.02.2018
Сообщений: 78
По умолчанию

Цитата:
Сообщение от 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

Последний раз редактировалось Eugene-LS; 03.12.2023 в 10:29.
Eugene-LS вне форума Ответить с цитированием
Старый 03.12.2023, 16:52   #3
Niyetkhan
Пользователь
 
Регистрация: 27.10.2016
Сообщений: 26
По умолчанию

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

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

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

С уважением,
Ниетхан
Niyetkhan вне форума Ответить с цитированием
Старый 03.12.2023, 17:17   #4
Eugene-LS
Пользователь
 
Аватар для Eugene-LS
 
Регистрация: 23.02.2018
Сообщений: 78
По умолчанию

Цитата:
Сообщение от 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
Успехов!

Последний раз редактировалось Eugene-LS; 03.12.2023 в 17:26.
Eugene-LS вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Удаление пустых строк в таблице Semen90 Microsoft Office Word 24 14.07.2022 12:28
Удаление пустых строк Dessz_de_Laerre Microsoft Office Excel 7 24.08.2016 13:07
Удаление пустых в документе TXT, DOC AlexDr Microsoft Office Word 7 20.03.2013 16:38
удаление абзацев D_e_n_n Microsoft Office Word 4 10.03.2011 18:33