Re: How to replace a string of characters with the count of the charac

Hi Peter,

I prefer to work with Range objects instead of the Selection whenever
possible, but in general this working example follows your outline except
for the final loop. I did have some trouble at first while trying to use the
same range for the loop as I had used for the preceding manipulations -- it
seemed unable to find anything -- but it all cleared immediately when I
started with a fresh range (oRg2) at that point.

Note that there's an entirely different scheme at
http://www.word.mvps.org/FAQs/MacrosVBA/NoTimesTextInDoc.htm, and another at
http://www.word.mvps.org/FAQs/MacrosVBA/GetNoOfReplacements.htm. With either
of those, it would be better to record the resulting numbers in a separate
document, instead of in-place replacement.

Sub CountChars()
Dim oRg As Range, oRg2 As Range
Dim CharNum As Long

Set oRg = ActiveDocument.Range

oRg.Case = wdUpperCase

With oRg.Find
.Format = False
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True

.Text = "[!A-Z]"
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll

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

oRg.Sort

Set oRg = ActiveDocument.Range
With oRg.Find
.Format = False
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = False

.Text = "^p"
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With

Set oRg2 = ActiveDocument.Range
With oRg2.Find
.Format = False
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
For CharNum = Asc("A") To Asc("Z")
.Text = "([" & Chr$(CharNum) & "]{1,})"
If .Execute Then
oRg2.Text = oRg2.Characters.Count & " "
Else
oRg2.Text = "0 "
End If
oRg2.Collapse wdCollapseEnd
Next CharNum
End With
End Sub

--
Regards,
Jay Freedman
Microsoft Word MVP FAQ: http://word.mvps.org
Email cannot be acknowledged; please post all follow-ups to the newsgroup so
all may benefit.

Ancient Brit wrote:
I have what seemed at first to be a trivial task for a Word 2003 SP2
macro (VB 6.3).

Given a body of text containing a range of characters (letters (upper
and lower case), digits, punctuation, spaces), all but the letters
A-Z need to be removed, then the resulting text needs to be sorted,
and finally, the count of each letter should replace each block of
sorted letters.

So: "I wandered lonely as a cloud, that floats on high o'er vales and
hills, etc., etc., with a few 12345 thrown in for good measure!"
becomes penultimately:
"AAAAAAAAACCCDDDDDEEEEEEEEEEFFFGGHHHHHHIIIIILLLLLLLMNNNNNNOOOOOOOOORRRRRSSSSSTTTTTTTUUVWWWWY"
and then finally: 9 0 3 5 10 3 2 6 5 0 0 7 1 6 9 0 0 5 5 7 2 1 4 0 1
0. (The zeros appear where a letter in the sequence is missing and so
the count for that letter is zero).

I did some searching around and found very useful information on the
use of Search/Replace with wildcards from Graham Mayor and Klaus
Linke at word.mvps.org (excellent job - thank you!. I've been using
MS Word for probably 15 years and I still find something to learn :))

My initial code worked OK - my approach was to first select the
entire body of text and render it upper case, then use Search/Replace
with the FIND wildcard sequence [!A-Z] and the REPLACE sequence null
to reduce the text to solely A-Z.

A subsequent Search/Replace on the text added a carriage return after
every character, the result was sorted, followed by another
Search/Replace to remove all the carriage returns. (There may be a
quicker/simpler way but I'm not aware of it.)

When it came to replacing each block of the same letter with its
count, I hit a snag. Try as I might, I cannot find a simple
programmatic way to do what I want.

I thought I had a solution when I tested a manual approach, using
FIND with Highlight checked (so the count is returned, but more
importantly the block of matching text is selected on exiting FIND,
so that - I thought - I could just replace the selection with the
contents of Selection.Characters.Count (and add a space as a
separator).

Not so. What works manually doesn't appear to work in a macro.

If I create a macro (even if I record one) that uses FIND to locate
and select all matching characters, upon completion only the first
character in the group is selected, whether I use Selection or Range.

I haven't found a bug report that describes the FIND problem - yet -
and there are clearly more complex workarounds that I could devise,
but I'd prefer to keep the solution minimal and simple if I can. I'd
be very grateful for some guidance, even if it's to say: "Use a
workaround; FIND is bugged."

Best,
Peter

Example code:
Sub M8()
'
' Macro M8 created 10/15/2007 by Peter GQ Brooks
'

' Sort the text. Simplest way is to begin by making everything upper
case (A-Z), then use
' Search/Replace to remove everything that is NOT in the range A-Z
(use wildcards and the
' expression [!A-Z] for the FIND and null for the REPLACE).
' Then replace every character with itself plus a carriage return,
making each character a
' line on its own, then sort, then delete all carriage returns
(replace every carriage return
' with a null).

' Select the entire document.
' Change case to upper.

Selection.WholeStory
Selection.Range.Case = wdUpperCase

' Ensure Find/Replace boxes have no prior formatting to impede process

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting

' Dump everything that isn't in the range A to Z.

With Selection.Find
.Text = "[!A-Z]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

' Now look for "any single character" and replace it with the same
character and a carriage return

With Selection.Find
.Text = "^?"
.Replacement.Text = "^&^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

' Sort entire document by paragraphs

Selection.Sort ExcludeHeader:=False, FieldNumber:="Paragraphs", _
SortFieldType:=wdSortFieldAlphanumeric,
SortOrder:=wdSortOrderAscending, _
FieldNumber2:="", SortFieldType2:=wdSortFieldAlphanumeric,
SortOrder2:= _
wdSortOrderAscending, FieldNumber3:="", SortFieldType3:= _
wdSortFieldAlphanumeric, SortOrder3:=wdSortOrderAscending,
Separator:= _
wdSortSeparateByTabs, SortColumn:=False, CaseSensitive:=False,
LanguageID _
:=wdEnglishUS, SubFieldNumber:="Paragraphs", SubFieldNumber2:=
_ "Paragraphs", SubFieldNumber3:="Paragraphs"

' Remove all carriage returns after sorting.

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^p"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

' Loop from A to Z and replace with count of character

For asciipointer = 65 To 90

Selection.Find.ClearFormatting
With Selection.Find
.Text = Chr(asciipointer)
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With

' Experimental section, trying various solutions:

' Set myRange = ActiveDocument.Content
' myRange.Find.Execute FindText:=Chr(asciipointer), Forward:=True
' Stop
' If myRange.Find.Found = True Then myRange.Text =
Selection.Characters.Count
' Stop

' Selection.Find.Execute
' 'Selection.Delete
' Stop
' MsgBox (Selection.Characters.Count)
' Selection.InsertBefore Selection.Characters.Count
' Stop
' 'Selection.Replace
Next asciipointer

End Sub


.

Relevant Pages
Loading