Sub SortRemoveAndTrackDuplicates2()

Dim oPars As Paragraphs, oPar1 As Paragraph, oPar2 As Paragraph, oRng As Range, i As Long, NumOc As Integer, DelRep As Integer

Set oPars = Selection.Range.Paragraphs

If oPars.Count > 1 Then

    Selection.Sort SortOrder:=wdSortOrderAscending

Else

    MsgBox "Não há seleção válida para classificar!", vbCritical, " ERRO!"
    Exit Sub

End If

If Selection.Information(wdWithInTable) Then

    MsgBox "Please move items to sort from table.  You can move them back into" _
    & " a table after sorting."
    Exit Sub

End If

NumOc = IIf(MsgBox("Inserir número de ocorrências?", vbYesNo, "  NÚMERO DE OCORRÊNCIAS?") = vbYes, 1, 0)
DelRep = IIf(MsgBox("Remover itens duplicados?", vbYesNo, "  REMOVER DUPLICADAS?") = vbYes, 1, 0)

Set oPar1 = oPars.Item(1)

Do

    i = 1

    Do

        Set oPar2 = oPar1.Next

        If oPar2.Range.Text = oPar1.Range.Text Then

            i = i + 1
            If DelRep = 1 Then oPar2.Range.Delete

        Else

            Exit Do
        
        End If

    Loop

    Set oRng = oPar1.Range
    oRng.End = oRng.End - 1
    If NumOc = 1 Then oRng.InsertAfter " (" & CStr(i) & ")"

    If oPar1.Range.End = oPars.Last.Range.End Then Exit Do

    Set oPar1 = oPar2
    
Loop

End Sub

If oPars.Count > 1 And Selection.Range.Paragraphs.Count < ActiveDocument.Paragraphs.Count Then
    Selection.Sort SortOrder:=wdSortOrderAscending
Else
    MsgBox "Não há seleção válida para classificar!", vbCritical, "  ERRO!"
    Exit Sub
End If

        If oPar2.Range.Text = oPar1.Range.Text Then
            i = i + 1
            If DelRep = 1 Then
                oPar2.Range.Delete
            Else
                Set oPar2 = oPar1.Next
                Exit Do
            End If
        Else
            Exit Do
        End If