Word VBA Макросы. Удалить одинаковые абзацы.

[Boom]

Помогите в обработке большого текста. Проблема в том, что в нем много совершенно одинаковых абзацев. Можно ли макросом удалить дубли и оставить только один?

Операцию нужно провести только в выделенном тексте.

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

В самих таблицах тоже нужно искать повторы абзацев? Или вы просто выделяете фрагмент, в котором могут быть таблицы, и нужно обработать только текст, не обрабатывая таблицы?

[Boom]

В таблицах я даже не знаю. У меня, к примеру, есть две таблички, где тоже повторяется текст. Но повторы присутствуют в разных ячейках таблицы (есть даже одинаковый текст не в одном столбце и не в одной строке). И потом, во многих ячейках цифры, которые удалять не нужно. Такая автоматизация для меня уж больно фантастическая.

А вот то, что мелкая таблица или еще какие элементы (списки, рисунки, надписи) попадают в выделение - это да (текст мой огромный, даже не знаю, откуда взятый, аж 600 листов с размерами шрифта 10-12).

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

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

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

А повторяющиеся абзацы разбросаны по файлу или находятся рядом, как в файле-примере из сообщения 1?

[Boom]

Разбросаны по тексту. Я обычно искал по тексту и сравнивал в режиме разделения экрана.
И, конечно, бывает несколько повторений (иногда аж 5 или 6).

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

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

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

Макрос

Sub Макрос()

    Dim arr() As String, r As Long, rng As Range
    Dim msg As Long, i As Long, ii As Long
   
   
    '1. Откл. монитора.
    Application.ScreenUpdating = False
   
    '2. Проверка, что что-то выделено.
    If Selection.Type = wdSelectionIP Then
        Application.ScreenUpdating = True
        MsgBox "Выделите фрагмент, в котором находятся абзацы.", vbExclamation
        Exit Sub
    End If
   
    '3. Если выделен только один абзац.
    If Selection.Paragraphs.Count = 1 Then
        Application.ScreenUpdating = True
        MsgBox "Выделен только один абзац.", vbExclamation
        Exit Sub
    End If
   
    '4. Vba-именование выделенного фрагмента. При удалении абзацев, не известно, как себя
        ' будет вести объект "Selection", поэтому будет обращаться к выделенному
        ' фрагменту не через Selection, а через vba-имя.
    Set rng = ActiveDocument.Range(Selection.Paragraphs.First.Range.Start, _
                Selection.Paragraphs.Last.Range.End)
               
    '5. Создание в массиве "arr" максимально возможного кол-ва элементов.
        ' В него будут записаны обыные абзацы: не абзацы таблиц и списков.
        ' В столбце 1 - текст абзацев.
        ' В столбце 2 - порядковые номера абзацев в выделенном фрагменте.
    ReDim arr(1 To rng.Paragraphs.Count, 1 To 2)
   
    '6. Запись в массив "arr" обычных абзацев. Пустые абзацы не учитываются.
    For i = 1 To rng.Paragraphs.Count Step 1
        If rng.Paragraphs(i).Range.Information(wdWithInTable) = False Then
            If rng.Paragraphs(i).Range.ListFormat.ListType = wdListNoNumbering Then
                If rng.Paragraphs(i).Range.Text <> Chr(13) Then
                    r = r + 1
                    arr(r, 1) = rng.Paragraphs(i).Range.Text
                    arr(r, 2) = i
                End If
            End If
        End If
    Next i
   
    '7. Проверка, что есть обычные абзацы.
    If r = 0 Then
        Application.ScreenUpdating = True
        MsgBox "Не выделено ни одного обычного абзаца: все абзацы находятся или в таблице, " & _
            "или представляют собой списки.", vbExclamation
        Exit Sub
    End If
   
    '8. Проверка, что обычных абзацев не одна штука.
    If r = 1 Then
        Application.ScreenUpdating = True
        MsgBox "Выделен только один обычный абзац.", vbExclamation
        Exit Sub
    End If
   
    '9. Удаление абзацев.
    For i = r To 2 Step -1
        ' Поиск текущего абзаца в тексте выше.
        For ii = 1 To i - 1 Step 1
            If arr(ii, 1) = arr(i, 1) Then
                ' Удаление абзаца.
                rng.Paragraphs(arr(i, 2)).Range.Delete
                ' Подсчёт удалённых абзаце.
                msg = msg + 1
                ' Остальные вышестоящие абзацы не просматриваются.
                Exit For
            End If
        Next ii
    Next i
   
    '11. Вкл. монитора.
    Application.ScreenUpdating = True
   
    '12. Сообщение.
    MsgBox "Удалено абзацев: " & msg, vbInformation
   
End Sub

[свернуть]

[Boom]

Выручили, спасибо большое! На моем тексте с таблицами и списками все сработало!

[BoomZoom]

Протестировал макрос. Отрабатывает так, как должен.
Хотел спросить - а существует ли решение, при котором один из абзацев будет удален, если совпадение не 100%, а, к примеру, 90% или 95% (ну или хотя бы длина строки отличается на пару символов)? Понимаю, что гораздо сложнее, но интерес практический: обнаружил, что во многих дублях у меня в предложении нет, к примеру, точки или стоит лишний пробел. Вручную приходится доделывать.

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

Сделать макрос, чтобы частично сравнивал абзацы (на 90-95%), для меня сложно.

Добавил две процедуры. Все три процедуры поместите в один модуль.
Одна процедура удаляет лишние пробелы: пробелы, которые находятся в начале абзаца, пробелы, которые находятся в конце абзаца, и несколько подрядрасположенных пробелов внутри абзаца.
Вторая процедура удаляет все точки в абзацах.
После чего макрос уже начинает искать дубликаты.

Две новые процедуры запускаются процедурой "Макрос".

Макрос

Sub Макрос()

    Dim arr() As String, r As Long, rng As Range
    Dim msg As Long, i As Long, ii As Long
   
   
    '1. Откл. монитора.
    Application.ScreenUpdating = False
   
    '2. Проверка, что что-то выделено.
    If Selection.Type = wdSelectionIP Then
        Application.ScreenUpdating = True
        MsgBox "Выделите фрагмент, в котором находятся абзацы.", vbExclamation
        Exit Sub
    End If
   
    '3. Если выделен только один абзац.
    If Selection.Paragraphs.Count = 1 Then
        Application.ScreenUpdating = True
        MsgBox "Выделен только один абзац.", vbExclamation
        Exit Sub
    End If
   
    '4. Vba-именование выделенного фрагмента. При удалении абзацев, не известно, как себя
        ' будет вести объект "Selection", поэтому будет обращаться к выделенному
        ' фрагменту не через Selection, а через vba-имя.
    Set rng = ActiveDocument.Range(Selection.Paragraphs.First.Range.Start, _
                Selection.Paragraphs.Last.Range.End)
               
    '5. Создание в массиве "arr" максимально возможного кол-ва элементов.
        ' В него будут записаны обыные абзацы: не абзацы таблиц и списков.
        ' В столбце 1 - текст абзацев.
        ' В столбце 2 - порядковые номера абзацев в выделенном фрагменте.
    ReDim arr(1 To rng.Paragraphs.Count, 1 To 2)
   
    '6. Запись в массив "arr" обычных абзацев. Пустые абзацы не учитываются.
    For i = 1 To rng.Paragraphs.Count Step 1
        If rng.Paragraphs(i).Range.Information(wdWithInTable) = False Then
            If rng.Paragraphs(i).Range.ListFormat.ListType = wdListNoNumbering Then
                If rng.Paragraphs(i).Range.Text <> Chr(13) Then
                    r = r + 1
                    arr(r, 1) = rng.Paragraphs(i).Range.Text
                    arr(r, 2) = i
                End If
            End If
        End If
    Next i
   
    '7. Проверка, что есть обычные абзацы.
    If r = 0 Then
        Application.ScreenUpdating = True
        MsgBox "Не выделено ни одного обычного абзаца: все абзацы находятся или в таблице, " & _
            "или представляют собой списки.", vbExclamation
        Exit Sub
    End If
   
    '8. Проверка, что обычных абзацев не одна штука.
    If r = 1 Then
        Application.ScreenUpdating = True
        MsgBox "Выделен только один обычный абзац.", vbExclamation
        Exit Sub
    End If
   
    '9. Обработка абзацев перед сравнением.
    '1) Удаление лишних пробелов
    Call DelSpaces(arr(), r)
    '2) Удаление всех точек.
    Call DelPoints(arr(), r)
   
    '10. Удаление абзацев.
    For i = r To 2 Step -1
        ' Поиск текущего абзаца в тексте выше.
        For ii = 1 To i - 1 Step 1
            If arr(ii, 1) = arr(i, 1) Then
                ' Удаление абзаца.
                rng.Paragraphs(arr(i, 2)).Range.Delete
                ' Подсчёт удалённых абзаце.
                msg = msg + 1
                ' Остальные вышестоящие абзацы не просматриваются.
                Exit For
            End If
        Next ii
    Next i
   
    '11. Вкл. монитора.
    Application.ScreenUpdating = True
   
    '12. Сообщение.
    MsgBox "Удалено абзацев: " & msg, vbInformation
   
End Sub

Private Sub DelSpaces(arr() As String, lr As Long)

    ' Удаление лишних пробелов: начальных, конечных и лишних внутри абзаца.
   
    Dim objExcel As Object, wsfunction As Object
    Dim i As Long
   
    Set objExcel = VBA.CreateObject(Class:="Excel.Application")
    Set wsfunction = objExcel.WorksheetFunction
    For i = 1 To lr Step 1
        arr(i, 1) = wsfunction.Trim(arr(i, 1))
    Next i
    objExcel.Quit

End Sub

Private Sub DelPoints(arr() As String, lr As Long)
    ' Удаление всех точек.
    Dim i As Long
    For i = 1 To lr Step 1
        arr(i, 1) = Replace(arr(i, 1), ".", "")
    Next i
End Sub

[свернуть]

[Boom]

Проверил работу. Все получается! Большая часть из того, что у меня не удалилась ранее - удалилось сейчас!
Большое спасибо!