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

Tech-Archive recommends: Fix windows errors by optimizing your registry

Peter,
This gets you closer to what you wanted:

Public Sub AlphabetCountString()
Dim CharNum As Long
Dim AlpahbetCountString As String
For CharNum = Asc("A") To Asc("Z")
AlpahbetCountString = AlpahbetCountString &
UBound(Split(ActiveDocument.Content, _
Chr$(CharNum), vbTextCompare)) & " "
Next CharNum
AlpahbetCountString = Replace(AlpahbetCountString, " 0 0 0 ", "C")
AlpahbetCountString = Replace(AlpahbetCountString, " 0 0 ", "B")
AlpahbetCountString = Replace(AlpahbetCountString, " 0 ", "A")
MsgBox AlpahbetCountString
End Sub

Peter,
Another way to get a speedy letter count without changing the document is to
use my new favorite function combination that I first saw used by Helmut
Weber. Using Jay's method to loop through the alphabet:

Public Sub LetterCount()
Dim CharNum As Long
For CharNum = Asc("A") To Asc("Z")
MsgBox Chr$(CharNum) & " = " & UBound(Split(ActiveDocument.Content, _
Chr$(CharNum), vbTextCompare))
Next CharNum
End Sub


The vbTextCompare tells it to ignore case, otherwise use vbBinaryCompare.
Another neat thing about the Ubound(Split()) is that it can also count
longer strings such as words or phrases.

Hi Jay

I wrote a moderately long reply but it seems to have gone AWOL - not sure of
the lag time between sending in something and having it appear in the
threads...

Anyway, at the risk of duplicating posts, I wanted to make sure I registered
my thanks and appreciation for your solution - my VB skills are very rusty
but I can appreciate a bit of crisp coding when I see it :)

In the interim I'd played around with MoveEndWhile and MoveStart but found
that Selection.Characters.Count somehow ended up with a value of 1 if nothing
was found, leading to an incorrect output. But since your solution is not
only correct but much faster than mine I'm happy to cease pursuing that line
of investigation :)

My next task is to make the output a little more sophisticated (read:
complicated), by (i) converting runs of zeros into letters (A for 0, B for 0
0, C for 0 0 0, etc), (ii) closing the gaps between the resulting letters and
numbers (but retaining spaces between numbers), so:

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

becomes:

9A3 5 10 3 2 6 5B7 1 6 9B5 5 7 2 1 4A1A

and finally (iii) dividing the [A-Z] source text into blocks of 125
characters if it exceeds 125, and processing each block independently.

I'm going to give that a bash but I suspect I may be back again before
long...:)

Once again, many thanks for your help.

Best,

Peter





"Jay Freedman" wrote:

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:

"AAAAAAAAACCCDDDDDEEEEEEEEEEFFFGGHHHHHHIIIIILLLLLLLMNNNNNNOOOOOOOOORRRRRSSS>>>>
S
STTTTTTTUUVWWWWY"
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




--
Russ

drsmN0SPAMikleAThotmailD0Tcom.INVALID

.

Relevant Pages