Удаление повторяющихся абзацев в тексте

[26.10.2021]

Приветствую!
У меня большой документ на 344 страницы с большим количеством повторяющихся предложений. Всего предложений 17,5 тыс.
Скажите, пожалуйста, если в макросе из этой темы: https://forumvba.ru/index.php?topic=395.0 заменить "paragraph" на "sentence", получится удалить повторы? И сколько примерно это займет времени?

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

С предложениями не так, как с абзацами.

Абзац имеет чёткие границы: абзац начинается и заканчивается символом "знак абзаца". Этот символ видно, если отобразить непечатаемые символы: вкладка Главная - группа Абзац - Отобразить все знаки.

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

[26.10.2021]

Благодарю за ответ. Вы правы, с предложениями не так просто будет.

Допустим, ворд как-то выделяет предложения, не будем в это вдаваться. Если точно так же сравнивать предложения и первое из повторяющихся подсветить зеленым, а остальные повторяющиеся желтым? А удалять потом вручную, просматривая желтые области? Так хотя бы будет видно повторы в тексте, а не с помощью ручного поиска Ctrl+f проверять каждое предложение.

Скажите, пожалуйста, сработает ли, если вместо строки удаления в том макросе (rng.Paragraphs(arr(i, 2)).Range.Delete) вставить такие строки:
rng.Sentences(arr(i, 2)).HighlightColorIndex = wdBrightGreen
rng.Sentences(arr(ii, 2)).HighlightColorIndex = wdYellow.

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

Весь код покажите, какой вы хотите использовать.

[26.10.2021]

Sub Макрос()

    Dim arr() As String, r As Long, rng As Range
    Dim msg As Long, i As Long, ii As Long
   
    Dim StartTime As Date
    Dim SecondsElapsed As Long
    Dim secondsPerComparison As Double
    Dim J, PC, totalComparisons, comparisonsDone, C, secondsToFinish 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.Sentences.First.Start, _
                Selection.Sentences.Last.End)
               
    '5. Создание в массиве "arr" максимально возможного кол-ва элементов.
        ' В него будут записаны обыные абзацы: не абзацы таблиц и списков.
        ' В столбце 1 - текст абзацев.
        ' В столбце 2 - порядковые номера абзацев в выделенном фрагменте.
    ReDim arr(1 To rng.Sentences.Count, 1 To 2)
   
    '6. Запись в массив "arr" обычных абзацев. Пустые абзацы не учитываются.
    For i = 1 To rng.Sentences.Count Step 1
        If rng.Sentences(i).Information(wdWithInTable) = False Then
            If rng.Sentences(i).ListFormat.ListType = wdListNoNumbering Then
                If rng.Sentences(i).Text <> Chr(13) Then
                    r = r + 1
                    arr(r, 1) = rng.Sentences(i).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.Sentences(arr(i, 2)).HighlightColorIndex = wdBrightGreen
                rng.Sentences(arr(ii, 2)).HighlightColorIndex = wdYellow
                ' Удаление абзаца.
                'rng.Paragraphs(arr(i, 2)).Range.Delete
                ' Подсчёт удалённых абзаце.
                msg = msg + 1
                ' Остальные вышестоящие абзацы не просматриваются.
               ' Exit For
            End If
        Next ii
        PC = rng.Sentences.Count
        comparisonsDone = PC * (i - 1) + (ii - i)
    SecondsElapsed = DateDiff("s", StartTime, Now())
    secondsPerComparison = CLng(SecondsElapsed) / comparisonsDone
    secondsToFinish = CLng(secondsPerComparison * (totalComparisons - comparisonsDone))
    minutesToFinish = Format(secondsToFinish / 86400, "hh:mm:ss")
    elapsedTime = Format(SecondsElapsed / 86400, "hh:mm:ss")
    Debug.Print "Finished procesing paragraph " & i & " of " & PC & ". Elapsed time = " & elapsedTime & ". Time to finish = " & minutesToFinish
    Next i
   
    '11. Вкл. монитора.
    'Application.ScreenUpdating = True
   
    '12. Сообщение.
    MsgBox "Удалено абзацев: " & msg, vbInformation
   
End Sub

[26.10.2021]

Скажите, пожалуйста, еще, как сильно повлияет на скорость кусок:
1. Откл. монитора.
Application.ScreenUpdating = False

И отключится ли монитор полностью или только документ с запущенным макросом?

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

Пункт 3 правильный для вашей задачи? В нём рассматривается абзац, а у вас предложения.
Монитор не отключается вообще - это так написано для краткости. Действия на мониторе не отображаются.
Сильно это повлияет на скорость или нет - не знаю, надо смотреть опытным путём.

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

На первый взгляд вы правильно адаптировали код под свою задачу.

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

Только сейчас макрос работает с учётом регистра.
Например, одно предложение: Доступные типы файлов.
Второе предложение: ДОСТУПНЫЕ ТИПЫ ФАЙЛОВ.

Для вашего макрос это разные предложения.

[26.10.2021]

Благодарю за ответ.
Пункт три для меня неактуален, я его просто закомментировала.
А где вы видите про регистр? Вообще, это неактуально. Просто интересно.

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

По умолчанию в VBA сравнение делается с учётом регистра.
Нужно явно указать или сделать код, чтобы макрос работал без учёта регистра.