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
