Sub ()
Dim di As Object, x, i As Long
Set di = CreateObject("scripting.dictionary")
di.comparemode = vbTextCompare 'не различать регистр букв
'наполнение словаря
For Each x In ActiveDocument.Sentences
x.MoveEndWhile vbCr & " ", wdBackward 'не учитывать знак абзаца и пробел после предложения
di(x.Text) = di(x.Text) + 1
Next
'удаление значений равных 1
For Each x In di.keys
If di(x) = 1 Then di.Remove x
Next
If di.Count = 0 Then MsgBox "повторяющихся нет!": Exit Sub
'запись в новый документ
With Documents.Add
With .Tables.Add(.Range, di.Count, 2)
For Each x In di.keys
i = i + 1
.Cell(i, 1).Range.Text = x
.Cell(i, 2).Range.Text = di(x)
Next
End With
End With
End Sub