Sub RemoveDoubleLinesInParagraph()
Dim rngPar As Range
Dim strText As String
Dim strWord As String
Dim myWords As New Collection
Dim iPos As Integer, iNew As Integer
Dim mc As Object
Dim arLines() As String, arOut() As String, iLine As Integer
Set rngPar = Selection.Paragraphs(1).Range
strText = rngPar.Text
arLines = Split(rngPar.Text, Chr(11))
For iLine = 0 To UBound(arLines)
Set mc = searchRegEx(arLines(iLine), "([a-z|A-Z| |0-9]+)(\.+)(\w+)")
If Not mc Is Nothing Then
strWord = mc.Item(0).SubMatches.Item(0)
If ExistsItem(myWords, strWord) Then
arLines(iLine) = ""
Else
myWords.Add strWord
End If
End If
Next
iNew = -1
For iPos = 0 To UBound(arLines)
If Not arLines(iPos) = "" Then
iNew = iNew + 1
ReDim Preserve arOut(iNew)
arOut(iNew) = arLines(iPos)
End If
Next
strText = Join(arOut, Chr(11))
Selection.Paragraphs(1).Range.Text = strText
End Sub
Function ExistsItem(colItems As Collection, strSearch As String) As Boolean
Dim iPos As Integer
For iPos = 1 To colItems.Count
If colItems.Item(iPos) = strSearch Then
ExistsItem = True
Exit For
End If
Next
End Function
Function searchRegEx(sourceString As String, pattern As String) As Object
Dim RegEx As Object
Set RegEx = CreateObject("VBScript.RegExp")
With RegEx
.MultiLine = True
.pattern = pattern
If .TEST(sourceString) Then
Set searchRegEx = .Execute(sourceString)
End If
End With
End Function