Continous Loop

[Greg Maxey]

I was trying to solve an OP question to remove all non-first letter text leaving a space where text was removed. First stab was:

Sub ScratchMacro()
Dim oWord As Word.Range
Dim oChr As Word.Range
Dim myRng As Word.Range
For Each oWord In ActiveDocument.Range.Words
For Each oChr In oWord.Characters
If Not oChr = oWord.Characters.First _
And Not oChr = " " Then
oChr.Text = " "
End If
Next oChr
Next

This resulted in a continous loop. Can someone explain what is causing the loop?

Thanks.

 

[Greg Maxey]

This worked without a continuous loop:

Sub ScratchMacro2()
Dim oWord As Word.Range
Dim oChr As Word.Range
For Each oWord In ActiveDocument.Range.Words
For Each oChr In oWord.Characters
If Not oChr = oWord.Characters.First _
And Not oChr = " " Then
oChr = Replace(oChr, oChr, " ")
End If
Next oChr
Next
End Sub


--
Greg Maxey/Word MVP
See:
http://gregmaxey.mvps.org/word_tips.htm
For some helpful tips using Word.

I was trying to solve an OP question to remove all non-first letter text leaving a space where text was removed. First stab was:

Sub ScratchMacro()
Dim oWord As Word.Range
Dim oChr As Word.Range
Dim myRng As Word.Range
For Each oWord In ActiveDocument.Range.Words
For Each oChr In oWord.Characters
If Not oChr = oWord.Characters.First _
And Not oChr = " " Then
oChr.Text = " "
End If
Next oChr
Next

This resulted in a continous loop. Can someone explain what is causing the loop?

Thanks.

 

[Doug Robbins - Word MVP]

If I understand what you were trying to do was to leave just the first
character of each word, I would use:

Dim oWord As Word.Range
For Each oWord In ActiveDocument.Range.Words
For i = 2 To oWord.Characters.Count
If Not oWord.Characters(i) = " " Then
oWord.Characters(i) = " "
End If
Next i
Next oWord
End Sub


--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP

I was trying to solve an OP question to remove all non-first letter text
leaving a space where text was removed. First stab was:

Sub ScratchMacro()
Dim oWord As Word.Range
Dim oChr As Word.Range
Dim myRng As Word.Range
For Each oWord In ActiveDocument.Range.Words
For Each oChr In oWord.Characters
If Not oChr = oWord.Characters.First _
And Not oChr = " " Then
oChr.Text = " "
End If
Next oChr
Next

This resulted in a continous loop. Can someone explain what is causing the
loop?

Thanks.

 

[Greg Maxey]

Doug,

Yes that would do it just as well. Still can't figure out why my first try
is generating a conitnuous loop. Can you offer an explanation?

 

[Tony Jollans]

I haven't done any real serious tests but it doesn't loop for me. It is
fairly slow, though - I guess it might feel like it was looping on a large
document.

If not that, what word or character was it looping on?

 

[Helmut Weber]

Hi Greg,

my sample text is:

Good evening. Submariner¶

There is no endless loop in neither macro here and now,
and furthermore, neither one works at all. :-(

Both result in:
G e e . S ¶

Use a non-proportional font for viewing.

hmm... I wonder very much.

Could have to do with replacing the second letter in a word
with a space results in an additional word.

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"

 

[Greg Maxey]

Helmut, Tony,

I am really confused now.

I tried time and again with:

"Now is the time for all good men to come to the aid of their country."

I was getting a continous loop immediately after the first "o" was replaced
with a space. Now for some reason I am not getting the loop. A Gremlin I
suppose.

Helmut you are correct the code is flawed. In my test using the line above,
by odd chance, the first letter is not repeated in any of the remaining
characters in the words. Therefore, Doug's method seems best of show ;-)

Sub Scratchmacro()
Dim oWord As Word.Range
For Each oWord In ActiveDocument.Range.Words
For i = 2 To oWord.Characters.Count
If Not oWord.Characters(i) = " " Then
oWord.Characters(i) = " "
End If
Next i
Next oWord
End Sub

 

[Helmut Weber]

Hi Greg, Tony, Doug,

one problem of course again, one of my favorite topics,
is Word's definition of a word.
There have been endless more or less useless discussions about it,
as "word" is a human concept and therefore fuzzy.

New sample text:
Good evening everybody. It's always a pleasure to discuss¶
things with learned people, who got a sense of humour.¶

New macro:
Sub test009876()
Dim oWrd As Word.Range
Dim rDcm As Word.Range
Set rDcm = ActiveDocument.Range
While rDcm.Start <> rDcm.End - 1
Set oWrd = rDcm.Words(1)
oWrd.Start = oWrd.Start + 1
oWrd.Text = String(Len(oWrd), " ")
rDcm.Start = rDcm.Start + Len(oWrd) + 1
rDcm.End = ActiveDocument.Range.End
Wend
End Sub

"It's" is regarded as _one_ word, it seems.


--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"

 

[Greg Maxey]

Helmut,

Your new code seems to produce the same result as Doug's version. An
interesting approach.

 

[Dave Lett]

Hi Greg,

I'm not sure why your code loops either. However, I think a wildcard replace
could meet your needs and do it more efficiently than cycling through each
word and character. Here's a sample that seems to work:

With Selection
.HomeKey Unit:=wdStory
With .Find
.ClearFormatting
.Text = "(<*)(*>)"
.MatchWildcards = True
With .Replacement
.ClearFormatting
.Text = "\1"
End With
.Execute Replace:=wdReplaceAll
End With
End With

HTH,
Dave

 

[Greg]

Dave,

Good to see you back. Seems you where away for a long spell. Your
method is certainly faster, but it doesn't preserve the space vacated
by the replaced letters. The OP wanted to preserve the spacing.

 

[Dave Lett]

Hi Greg,

Yes, I was away for a good spell--marriage, new job, that kind of thing. As
soon as I posted my first message, I figured out what you were REALLY looking
for, so here's my next effort at meeting that goal. Hope it's what you're
looking for:

Dim iLoop As Integer
Dim sBlanks As String
Dim sReplace As String
Dim iLen As Integer
sBlanks = " "

With Selection
.HomeKey Unit:=wdStory
With .Find
.ClearFormatting
.Text = "(<*)(*>)"
.MatchWildcards = True
Do While .Execute
Set oRng = Selection.Range
iLen = Len(oRng.Text)
sReplace = ""
For iLoop = 2 To iLen
sReplace = sReplace & sBlanks
Next iLoop
With .Replacement
.Text = "\1" & sReplace
End With
.Execute Replace:=wdReplaceOne
Selection.MoveRight
Loop
End With
End With


HTH,
Dave

 

[Greg]

Dave,

Yes that produces the desired result. I haven't timed it, but do you
think it is appreciably faster than Doug Robbin's suggestion?

Dim oWord As Word.Range
For Each oWord In ActiveDocument.Range.Words
For i = 2 To oWord.Characters.Count
If Not oWord.Characters(i) = " " Then
oWord.Characters(i) = " "
End If
Next i
Next oWord
End Sub

 

[Greg]

Dave,

Yes that produces the desired result. I haven't timed it, but do you
think it is appreciably faster than Doug Robbin's suggestion?

Dim oWord As Word.Range
For Each oWord In ActiveDocument.Range.Words
For i = 2 To oWord.Characters.Count
If Not oWord.Characters(i) = " " Then
oWord.Characters(i) = " "
End If
Next i
Next oWord
End Sub

 

[Greg]

Dave,

Yes that produces the desired result. I haven't timed it, but do you
think it is appreciably faster than Doug Robbin's suggestion?

Dim oWord As Word.Range
For Each oWord In ActiveDocument.Range.Words
For i = 2 To oWord.Characters.Count
If Not oWord.Characters(i) = " " Then
oWord.Characters(i) = " "
End If
Next i
Next oWord
End Sub

 

[Dave Lett]

Hi Greg,

I created a six-page document. Each paragraph is identical and is
Good evening. Submariner

The following shows the results:
Alternative routine: Time taken was: 1.78125 seconds '846 actions
Doug's Routine: Time taken was: 3.265625 seconds '5076 actions
(when the alternative routine was run first)

I then closed Word, opened it, and ran both routines again with Doug's first:
Time taken was: 2.390625 seconds
Time taken was: 1.921875 seconds

So, is it _appreciably_ better? I guess that depends on the
length/complexity of the document. I like the reduced number of actions,
though.

I then tinkered with some of the code and came up with the following:
Dim iLen As Integer
With Selection
.HomeKey Unit:=wdStory
With .Find
.ClearFormatting
.Text = "(<*)(*>)"
.MatchWildcards = True
Do While .Execute
iLen = Len(Selection.Text)
With .Replacement
.Text = "\1" & String(iLen, " ")
End With
.Execute Replace:=wdReplaceOne
Selection.MoveRight
Loop
End With
End With

The time taken was: 1.5625 seconds, so this might be closer to appreciably
faster.
I've been trying to figure out a method for replacing without having to
loop, which would probably be the fastest method, but I can't seem to get it.

Dave

 

[Greg]

Dave,

Based on your testing, I suppose it is a bit faster.

Your code is adding an extra space for each word. Change the line:

iLen = Len(Selection.Text) as shown below and it works correctly:

Sub Test()
Dim iLen As Integer
With Selection
.HomeKey Unit:=wdStory
With .Find
.ClearFormatting
.Text = "(<*)(*>)"
.MatchWildcards = True
Do While .Execute
iLen = Len(Selection.Text) - 1
With .Replacement
.Text = "\1" & String(iLen, " ")
End With
.Execute Replace:=wdReplaceOne
Selection.MoveRight
Loop
End With
End With

End Sub

 

[Dave Lett]

Hi Greg,

FYI and FWIW.
I've improved the speed again with the following changes (Time taken was:
0.921875 seconds):
With Selection
.HomeKey Unit:=wdStory
With .Find
.ClearFormatting
.Text = "(<*>)"
.MatchWildcards = True
Do While .Execute
With Selection
.Text = Left(.Text, 1) & String(Len(.Text) - 1, " ")
.MoveRight
End With
Loop
End With
End With

Dave

 

[Helmut Weber]

Hi Dave,

just out of curiosity.

Did you try this:

Sub test009876()
Dim oWrd As Word.Range
Dim rDcm As Word.Range
Set rDcm = ActiveDocument.Range
Dim s As Single
s = Timer
While rDcm.Start <> rDcm.End - 1
Set oWrd = rDcm.Words(1)
oWrd.Start = oWrd.Start + 1
oWrd.Text = String(Len(oWrd), " ")
rDcm.Start = rDcm.Start + Len(oWrd) + 1
rDcm.End = ActiveDocument.Range.End
Wend
MsgBox Timer - s
End Sub

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"

 

[Dave Lett]

Hi Helmut,

In my testing it runs

Time taken was: 0.765625 seconds

If you group the range objects using With (makes it less readable though),
you can get it down to "Time taken was: 0.703125 seconds"

So, no, i didn't try your code, and if I had done so first, i wouldn't have
bothered with the thread. Using the range object is clearly the best method
(since we can't do a replace) and your code has the added advantage of not
bouncing the screen all over the place.

Dave