Comparing ranges problem

[David]

XP/ XP Office

I have a list of words in a word doc file. One word on each line. I
have sorted the list. Many words are duplicated. I'm trying to
delete all duplicate words.

I've tried FIND(*^13)\1 REPLACE WITH \1, but it still leaves many
dups. It also takes over 4 minutes with 2700 words. I figured I
could iterate through the list once to remove dups.

So I wrote this code...

'Remove any dup lines
Dim Word1, Word2 As Range

Set Word1 = Documents("WorkArea1.doc").Words(1)

NumOfWords% = Documents("WorkArea1.doc").Words.Count
For A% = 2 To NumOfWords
Set Word2 = Documents("WorkArea1.doc").Words(A)
If Word1 = Word2 Then '<<<< Problem here
Documents("WorkArea1.doc").Words(A).Delete
Else
Word1 = Documents("WorkArea1.doc").Words(A)
End If
Next

But then it compares Word1 to Word2, either one or the other always is
empty. When I step through, and it steps past Set Word2, I hover the
cursor over each range, and they both contain words, but as soon as I
compare, one is always empty.

What am I doing wrong?

 

[Peter Hewett]

Hi

The following code should do what you want, it exepects each word on it's
own line and expects the list to be in a sorted order. When a duplicate
word is found it deletes the entire line containing the duplicate word. The
comparisons case insensitive:

Public Sub RemoveDuplicateWords()
Dim rngReplace As Word.Range
Dim rngFound As Word.Range
Dim strLastWord As String
Dim strThisWord As String

Set rngReplace = ActiveDocument.Content
With rngReplace.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "<*>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True

' Find all occurrences in the document
Do While .Execute

'
Set rngFound = rngReplace.Duplicate
strThisWord = rngFound.Text

' Ignore the very first word found
If LenB(strLastWord) > 0 Then

' If current word is the sane as the last then delete it
If StrComp(strThisWord, strLastWord, _
vbTextCompare) = 0 Then

' Each word on its own line so delete entire line
rngFound.Select
Selection.Expand wdLine
Selection.Delete
End If
End If
strLastWord = strThisWord

' Setup range to continue the search after
' the text that we just found/deleted
rngReplace.Collapse wdCollapseEnd
Loop
End With
End Sub


HTH + Cheers - Peter


(e-mail address removed) (David) wrote in

 

[David]

Thanks Peter!

 

[Jezebel]

Another approach to this kind of problem is to copy the list to Excel, use
its functions (like unique filter) then paste the last back to Word. For
one-off tasks, it's usually quicker than writing VBA code.