Приветствую!
У меня большой документ на 344 страницы с большим количеством повторяющихся предложений. Всего предложений 17,5 тыс.
Скажите, пожалуйста, если в макросе из этой темы: https://forumvba.ru/index.php?topic=395.0 заменить "paragraph" на "sentence", получится удалить повторы? И сколько примерно это займет времени?
С предложениями не так, как с абзацами.
Абзац имеет чёткие границы: абзац начинается и заканчивается символом "знак абзаца". Этот символ видно, если отобразить непечатаемые символы: вкладка Главная - группа Абзац - Отобразить все знаки.
Предложение не имеет чётких границ. Я даже не знаю, как Ворд определяет границы предложения. К тому же внутри предложения могут быть точки. Например, для Ворда это два предложения:
Слово слово слово ул. Космонавтов.
Первое предложение: Слово слово слово ул.
Второе предложения: Космонавтов.
Благодарю за ответ. Вы правы, с предложениями не так просто будет.
Допустим, ворд как-то выделяет предложения, не будем в это вдаваться. Если точно так же сравнивать предложения и первое из повторяющихся подсветить зеленым, а остальные повторяющиеся желтым? А удалять потом вручную, просматривая желтые области? Так хотя бы будет видно повторы в тексте, а не с помощью ручного поиска Ctrl+f проверять каждое предложение.
Скажите, пожалуйста, сработает ли, если вместо строки удаления в том макросе (rng.Paragraphs(arr(i, 2)).Range.Delete) вставить такие строки:
rng.Sentences(arr(i, 2)).HighlightColorIndex = wdBrightGreen
rng.Sentences(arr(ii, 2)).HighlightColorIndex = wdYellow.
Весь код покажите, какой вы хотите использовать.
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
Скажите, пожалуйста, еще, как сильно повлияет на скорость кусок:
1. Откл. монитора.
Application.ScreenUpdating = False
И отключится ли монитор полностью или только документ с запущенным макросом?
Пункт 3 правильный для вашей задачи? В нём рассматривается абзац, а у вас предложения.
Монитор не отключается вообще - это так написано для краткости. Действия на мониторе не отображаются.
Сильно это повлияет на скорость или нет - не знаю, надо смотреть опытным путём.
На первый взгляд вы правильно адаптировали код под свою задачу.
Только сейчас макрос работает с учётом регистра.
Например, одно предложение: Доступные типы файлов.
Второе предложение: ДОСТУПНЫЕ ТИПЫ ФАЙЛОВ.
Для вашего макрос это разные предложения.
Благодарю за ответ.
Пункт три для меня неактуален, я его просто закомментировала.
А где вы видите про регистр? Вообще, это неактуально. Просто интересно.
По умолчанию в VBA сравнение делается с учётом регистра.
Нужно явно указать или сделать код, чтобы макрос работал без учёта регистра.