Removing partial duplicate lines in Word

I have reports with duplicate names, and I have a macro that can remove the duplicates.

My problem is that sometime the duplicate names are not removed because of sometime there is metadata that is not the same from one duplicate to the next.

It looks like this

4556           Smith, Bob

4556           Smith, Bob

4556           Smith, Bob

7777           Smith, Bob

8877           Smith, Bob

I can get to

4556           Smith, Bob

7777           Smith, Bob

8877           Smith, Bob

My problem is that I need to keep at least one line without taking the metadata out of that one line because i don't have full control over these reports so i can't just delete all the metadata.

Disclosure: The actual macro I use is some mighty  fine code written by someone other than myself. I

http://windowssecrets.com/forums/showthread.php/75402-Macro-to-Remove-Duplicate-Entries-(MS-Word-2003)

Sub RemoveDupEntries()

Dim para As Paragraph

Dim doc As Document

Dim vEntries() As Variant

Dim vDupEntries() As Variant

Dim sParaText As String

ReDim vEntries(0)

ReDim vDupEntries(0)

Set doc = ActiveDocument

For Each para In doc.Paragraphs

sParaText = Left(para.Range.Text, para.Range.Characters.Count - 1)

If IsMember(vEntries, sParaText) Then

If IsMember(vDupEntries, sParaText) = False Then

Push vDupEntries, sParaText

End If

para.Range.Delete

Else

Push vEntries, sParaText

End If

Next para

' Now vDupEntries contains any items that were duplicated.

' You can insert it at the end of doc 3 as needed

' For example:

' Documents("Doc3").Content.InsertAfter Join(vDupEntries, vbCr)

End Sub

'

Function Push(ByRef vArray As Variant, ByVal str As String)

ReDim Preserve vArray(UBound(vArray) + 1)

vArray(UBound(vArray)) = str

End Function

'

Function IsMember(vArray As Variant, ByVal str As String)

Dim v As Variant

For Each v In vArray

If v = str Then

IsMember = True

Exit Function

End If

Next v