How to find only words consisting of upper case characters and howexclude of repeating words?

[avkokin]

Hello.
There is code that copy all upper case words into end of document
(thank's Jean-Guy Marcil and others):
Dim rngDoc As Word.Range
Dim wu As Word.Range
Dim lngDocEnd As Long
Set rngDoc = ActiveDocument.Range
lngDocEnd = rngDoc.End
For Each wu In rngDoc.Words
If wu.Case = wdUpperCase Then
ActiveDocument.Range.InsertAfter vbCrLf & wu.Text
rngDoc.End = lngDocEnd
End If
Next wu
However if the text contains as well as single characters (upper case)
they too will copy with words. I tried to add condition of checking of
amount characters into found words (>=2) but I got too one character
and space. If I change of amount characters to 3, then word consisting
of 2 symbols will lost
Question: how to check and get only words (upper case) and How exclude
repeating words from found?
Thank you very much.

 

[Graham Mayor]

Change the line
If wu.Case = wdUpperCase Then
to
If wu.Case = wdUpperCase And Len(wu) > 2 Then

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

 

[avkokin]

Change the line
If wu.Case = wdUpperCase Then
to
If wu.Case = wdUpperCase And Len(wu) > 2 Then

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP

My web sitewww.gmayor.com
Word MVP web sitehttp://word.mvps.org
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

Hello Graham, thank's. I did it. But if after word than consisting of
2 symbols is dot (e.g. "NO. Thank you"), then this word ("NO") will
lost. For example see the file (http://www.box.net/shared/kdayomkws8).
In addition how to exclude repeating words from found?
Thank you very much.

 

[Graham Mayor]

As for the elimination of duplicates, the following is not very elegant, but
does the job

Dim rngDoc As Word.Range
Dim wu As Word.Range
Dim lngDocEnd As Long
Set rngDoc = ActiveDocument.Range
lngDocEnd = rngDoc.End
With ActiveDocument
Selection.EndKey Unit:=wdStory
Selection.TypeParagraph
.Bookmarks.Add Range:=Selection.Range, name:="ListStart"
For Each wu In rngDoc.Words
If wu.Case = wdUpperCase Then
.Range.InsertAfter vbCrLf & wu.Text
rngDoc.End = lngDocEnd
End If
Next wu
.Bookmarks("ListStart").Select
With Selection
.EndKey Unit:=wdStory, Extend:=wdExtend
.Sort , FieldNumber:="Paragraphs", _
SortFieldType:=wdSortFieldAlphanumeric, _
SortOrder:=wdSortOrderAscending
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "(*^13)@"
.Replacement.Text = "\1"
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
End With
End With


--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

 

[Graham Mayor]

Hmmm

How about the following - ugly but it appears to fix both issues and works
with your test document

Dim rngDoc As Word.Range
Dim wu As Word.Range
Dim lngDocEnd As Long
Set rngDoc = ActiveDocument.Range
lngDocEnd = rngDoc.End
With ActiveDocument
Selection.EndKey Unit:=wdStory
Selection.TypeParagraph
.Bookmarks.Add Range:=Selection.Range, name:="ListStart"
For Each wu In rngDoc.Words
If wu.Case = wdUpperCase Then
.Range.InsertAfter vbCrLf & wu.Text
rngDoc.End = lngDocEnd
End If
Next wu
.Bookmarks("ListStart").Select
With Selection
.EndKey Unit:=wdStory, Extend:=wdExtend
.Sort , FieldNumber:="Paragraphs", _
SortFieldType:=wdSortFieldAlphanumeric, _
SortOrder:=wdSortOrderAscending
With .Find
.ClearFormatting
.Replacement.ClearFormatting

.Text = "[ ](^13)"
.Replacement.Text = "\1"
.MatchWildcards = True
.Execute Replace:=wdReplaceAll

.Text = "(*^13)@"
.Replacement.Text = "\1"
.MatchWildcards = True
.Execute Replace:=wdReplaceAll

.Text = "([!A-Z])[A-Z]^13"
.Replacement.Text = "\1"
.Execute Replace:=wdReplaceAll
End With
End With
End With


--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

 

[avkokin]

As for the elimination of duplicates, the following is not very elegant, but
does the job

Dim rngDoc As Word.Range
Dim wu As Word.Range
Dim lngDocEnd As Long
Set rngDoc = ActiveDocument.Range
lngDocEnd = rngDoc.End
With ActiveDocument
Selection.EndKey Unit:=wdStory
Selection.TypeParagraph
.Bookmarks.Add Range:=Selection.Range, name:="ListStart"
For Each wu In rngDoc.Words
If wu.Case = wdUpperCase Then
.Range.InsertAfter vbCrLf & wu.Text
rngDoc.End = lngDocEnd
End If
Next wu
.Bookmarks("ListStart").Select
With Selection
.EndKey Unit:=wdStory, Extend:=wdExtend
.Sort , FieldNumber:="Paragraphs", _
SortFieldType:=wdSortFieldAlphanumeric, _
SortOrder:=wdSortOrderAscending
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "(*^13)@"
.Replacement.Text = "\1"
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
End With
End With

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP

My web sitewww.gmayor.com
Word MVP web sitehttp://word.mvps.org
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

Graham, I'm very grateful for you, but it not correct working. I think
that problem is in the space after words. For example I update that
file (http://www.box.net/shared/kdayomkws8) end use this macro. Yes,
it sort words but leave repeating words (3 words NO).

 

[avkokin]

Hmmm

How about the following - ugly but it appears to fix both issues and works
with your test document

Dim rngDoc As Word.Range
Dim wu As Word.Range
Dim lngDocEnd As Long
Set rngDoc = ActiveDocument.Range
lngDocEnd = rngDoc.End
With ActiveDocument
Selection.EndKey Unit:=wdStory
Selection.TypeParagraph
.Bookmarks.Add Range:=Selection.Range, name:="ListStart"
For Each wu In rngDoc.Words
If wu.Case = wdUpperCase Then
.Range.InsertAfter vbCrLf & wu.Text
rngDoc.End = lngDocEnd
End If
Next wu
.Bookmarks("ListStart").Select
With Selection
.EndKey Unit:=wdStory, Extend:=wdExtend
.Sort , FieldNumber:="Paragraphs", _
SortFieldType:=wdSortFieldAlphanumeric, _
SortOrder:=wdSortOrderAscending
With .Find
.ClearFormatting
.Replacement.ClearFormatting

.Text = "[ ](^13)"
.Replacement.Text = "\1"
.MatchWildcards = True
.Execute Replace:=wdReplaceAll

.Text = "(*^13)@"
.Replacement.Text = "\1"
.MatchWildcards = True
.Execute Replace:=wdReplaceAll

.Text = "([!A-Z])[A-Z]^13"
.Replacement.Text = "\1"
.Execute Replace:=wdReplaceAll
End With
End With
End With

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP

My web sitewww.gmayor.com
Word MVP web sitehttp://word.mvps.org
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

Hello Graham, thank's. I did it. But if after word than consisting of
2 symbols is dot (e.g. "NO. Thank you"), then this word ("NO") will
lost. For example see the file (http://www.box.net/shared/kdayomkws8).
In addition how to exclude repeating words from found?
Thank you very much.

I'm very greatful for you! Thank's, it worked.

 

[Graham Mayor]

This one as you may have guessed was posted a little hastily. The answer
lies in the later version.

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

 

[avkokin]

This one as you may have guessed was posted a little hastily. The answer
lies in the later version.

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP

My web sitewww.gmayor.com
Word MVP web sitehttp://word.mvps.org
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

Graham, sorry I didn't understand your answer, but I deleted my
previous post as I really a little hastily informed you and don't see
your last correct of code. I am very much obliged to you.

 

[Graham Mayor]

Graham, sorry I didn't understand your answer, but I deleted my
previous post as I really a little hastily informed you and don't see
your last correct of code. I am very much obliged to you.

Now it's my turn to be puzzled. You responded to a branch of the thread that
the alternative version worked for you. The code in that branch was:

Dim rngDoc As Word.Range
Dim wu As Word.Range
Dim lngDocEnd As Long
Set rngDoc = ActiveDocument.Range
lngDocEnd = rngDoc.End
With ActiveDocument
Selection.EndKey Unit:=wdStory
Selection.TypeParagraph
.Bookmarks.Add Range:=Selection.Range, name:="ListStart"
For Each wu In rngDoc.Words
If wu.Case = wdUpperCase Then
.Range.InsertAfter vbCrLf & wu.Text
rngDoc.End = lngDocEnd
End If
Next wu
.Bookmarks("ListStart").Select
With Selection
.EndKey Unit:=wdStory, Extend:=wdExtend
.Sort , FieldNumber:="Paragraphs", _
SortFieldType:=wdSortFieldAlphanumeric, _
SortOrder:=wdSortOrderAscending
With .Find
.ClearFormatting
.Replacement.ClearFormatting

.Text = "[ ](^13)"
.Replacement.Text = "\1"
.MatchWildcards = True
.Execute Replace:=wdReplaceAll

.Text = "(*^13)@"
.Replacement.Text = "\1"
.MatchWildcards = True
.Execute Replace:=wdReplaceAll

.Text = "([!A-Z])[A-Z]^13"
.Replacement.Text = "\1"
.Execute Replace:=wdReplaceAll
End With
End With
End With


--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>