limit text to 200 words - or - how do I remove the last word in a Word document

I'm actually using Excel to populate a Word document in order to count the words in a text field. I want to return only 200 words from the Word document to the Excel VBA. I'm attaching what I have already. The problem seems to be that "oSelection.Range.Words.last.Delete " doesn't do what I think it should. Is this the proper usage or is there another/better way to do this?

Thanks
' Excel 2002 Code
' --------------------
Dim oWord As Object
Dim oWordDocument As Object
Dim oSelection As Object

Set oWord = CreateObject("Word.application")
oWord.Visible = True
Set oWordDocument = oWord.documents.Add
Set oSelection = oWord.Selection
oSelection.typetext Trim(Cells(Selection.Row, iColumnToLimitWords).Value)

oSelection.WholeStory

' loop counting the words and then deleting one word at a time until the limit is reached
Do While oWord.ActiveDocument.Range.ComputeStatistics(0) >= iNumberOfWordsAllowed
    oSelection.WholeStory
    
    oSelection.Range.Words.last.Delete  ' THIS LINE SEEMS TO DO NOTHING

Loop

oWordDocument.Selection.WholeStory
oWordDocument.Selection.Copy

Cells(Selection.Row, iColumnToLimitWords).Value = ActiveWorkbook.Paste

Open in new window

GordJonesAsked:
Who is Participating?
 
GrahamSkanConnect With a Mentor RetiredCommented:
You can replace the paragraph marks with spaces.
Sub TwoHundredWords()
    Dim rng As Range
    Dim rng2 As Range
    
    Do Until ActiveDocument.Range.ComputeStatistics(0) <= 200
        Set rng = ActiveDocument.Range
        Set rng2 = rng.Words.Last
        Do While rng2.Text = Chr$(13)
            rng.End = rng2.Start
            Set rng2 = rng.Words.Last
            rng2.Delete
        Loop
    Loop
    With ActiveDocument.Range.Find
        .Text = "^p"
        .Replacement.Text = " "
        .Execute Replace:=wdReplaceAll
    End With
 End Sub

Open in new window

0
 
Tommy KinardCommented:
I would reccomend that you do this, limit the information being sent to Word, only send 200 words.

HTH
dragontooth


Function KillGT200(Info As Variant) As String
    Dim HldData() As String
    HldData = Split(Trim(CStr(Info)), " ")
    If UBound(HldData, 1) > 200 Then ReDim Preserve HldData(200)
    KillGT200 = Join(HldData, " ")
End Function

usage:
oSelection.typetext KillGT200(Cells(Selection.Row, iColumnToLimitWords).Value)

Open in new window

0
 
GordJonesAuthor Commented:
This has flaws in that when a sentence ends and a new one begins they could all be considered 1 word. The following example would only have 3 words since there are no spaces between "end.New"... only a special character of a linefeed:
The end.
New sentence.
 
0
Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
Tommy KinardCommented:
This should fix you right up.

dragontooth


Do While oWord.ActiveDocument.Range.ComputeStatistics(0) >= iNumberOfWordsAllowed
    oSelection.WholeStory
     
 oSelection.Collapse Direction:=wdCollapseEnd

    oSelection.MoveEnd Unit:=wdWord, Count:=-1
    oSelection.Delete Unit:=wdWord, Count:=1
Loop

Open in new window

0
 
Tommy KinardConnect With a Mentor Commented:
Another way much faster

dragontooth
Sub betterway()
    Dim mI As Long
    mI = ActiveDocument.Range.ComputeStatistics(0)
    If mI > 200 Then
        Selection.WholeStory
        Selection.Collapse Direction:=wdCollapseEnd
        Selection.MoveEnd Unit:=wdWord, Count:=-(mI - 200)
        Selection.Delete Unit:=wdWord, Count:=(mI - 200)
    End If
 End Sub

Open in new window

0
 
GordJonesAuthor Commented:
works great but one problem :(
Selection.MoveEnd Unit:=wdWord, Count:=-(mI - 200)
This line is doing a "Words" count instead of using the  "ComputeStatistics(0)" words count  :(  So it is gettings special characters, etc included and ending up with more than 200 "real" words.
0
 
GrahamSkanRetiredCommented:
Yes. ComputeStatistics(0) returns a number less than the Words collection count.

A paragraph with date: "07/01/10¶" counts as six in the Words collection, but is only one in ComputeStatistics(0).

Also the last paragraph cannot be deleted.

See if this helps

 


Sub TwoHundredWords()
    Dim rng As Range
    Dim rng2 As Range
    
    Do Until ActiveDocument.Range.ComputeStatistics(0) <= 200
        Set rng = ActiveDocument.Range
        Set rng2 = rng.Words.Last
        Do While rng2.Text = Chr$(13)
            rng.End = rng2.Start
            Set rng2 = rng.Words.Last
            rng2.Delete
        Loop
    Loop
 End Sub

Open in new window

0
 
GordJonesAuthor Commented:
That worked great!
Now hopefully the final problem... when I paste back into Excel, and the text contains paragraphs, the text is ending up in 2 cells instead of all in one as I would like it. Example:
"This is a test.
 
This is the second paragraph. "
When this Word text is pasted back into Excel each paragraph is inserted on a separate row :( How can I force Excel to past all the text into a single cell?
0
 
GordJonesAuthor Commented:
That's what I'm looking for, thanks. I'll be taking it a step furtur and instead of relacing with a space, I'll replace with my own special character. Then once the text is in the Excel cell I'll replace it back into being a paragraph break :)
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.