Solved: Need Loop Help; and to Step it Through All Stories

[Ice-Tea-Jan]

Hello,

I have documents that sometimes (but not always) have highlighted material that is smack up against strikethrough material without a space.


Sample:
Now is the time forall good men to come to the aid of their country.
A rat in the house might eat the ice cream.


In other words, I would need to insert a space after the word “for”; but NOT after the word “house.”

Thus far, my macro (sample below):

Searches for chunks of highlighted material, then stops to select the next character
If this next character IS NOT a space, it backs up & inserts a space, (it also backs up again to unhighlight the newly-inserted space).

If that next character IS a space, then it moves on to search for next clump of highlighted material.

As you may guess, the loop works once, but I need to loop up to a “stop point.”

Problem is:

I can't use "while selection.find.found" because there will be always chucks of highlights to search for.
I can't use “while space is found” as there will always be other highlighted areas that already contain a space there.
I tried a “do while selection <> “ “; but that did not work either.
Can anybody please assist me?

Here is my code thus far:

Sub Add SpaceAfterHighlights()
'
'Searchs for chunks of highlighted material, stops and selects the next character (via F8 extend)
Selection.Find.ClearFormatting
Selection.Find.Highlight = True
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
'
'
'Moves and selects the NEXT character so "if" statement can decide on how to proceed
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Extend
Selection.MoveRight Unit:=wdCharacter, Count:=1
'
'
'If the selection IS NOT a space, then it backs up and inserts a space
If Selection <> " " Then
Selection.ExtendMode = False
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Overtype = Not Overtype
Selection.TypeText Text:=" "
'
'Then it backs up again, selects this newly inserted space & dehighlights the space
Selection.Extend
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.Range.HighlightColorIndex = wdNoHighlight
Selection.MoveRight Unit:=wdCharacter, Count:=1

'If not a space in that spot, then is searchs again for next clump of highlighted material
Else
Search.again
End If
'
'
End Sub

[Ice-Tea-Jan]

Sample:
Now is the time forall good men to come to the aid of their country.
A rat in the house might eat the ice cream.

Sorry

[Tinbendr]

Sub Add SpaceAfterHighlights()
'
'Searchs for chunks of highlighted material,
'stops and selects the next character (via F8 extend)
do
Selection.Find.ClearFormatting
'.... rest of your code here

'If not a space in that spot, then search
'again for next clump of highlighted material
End If
loop until not selection.find.found

[Ice-Tea-Jan]

Sorry, Tinbendr but that did not work? :(

(Your proposed corrections to my code is pasted below.)

But thanks for that lightening-fast reply.

I believe the focus should be on the NEXT character selected -- and not act upon the selection that is found, and will continue to be found?

Also the sample I posted may be a bit confusing, but the bold letters are actually "highlighted" (as the search shows).

Anybody else hlep me with this?

Thanking you,

Here is the code:

Sub SplitTrackedChangesSept()
'
'Searchs for chunks of highlighted material, stops and selects the next character (via F8 extend)
Selection.Find.ClearFormatting
Selection.Find.Highlight = True
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
'
'
'Moves and selects the NEXT character so "if" statement can decide on how to proceed
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Extend
Selection.MoveRight Unit:=wdCharacter, Count:=1
'
Do
'If the selection IS NOT a space, then it backs up and inserts a space
If Selection <> " " Then
Selection.ExtendMode = False
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Overtype = Not Overtype
Selection.TypeText Text:=" "
'
'Then it backs up again, selects this newly inserted space & dehighlights the space
Selection.Extend
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.Range.HighlightColorIndex = wdNoHighlight
Selection.MoveRight Unit:=wdCharacter, Count:=1
End If
Loop Until Not Selection.Find.Found
'
End Sub

[Ice-Tea-Jan]

Sorry, but the sample text did not hold the highlighting as desired.

I will try to make red and bold this again.

Sample:
Now is the time forall good men to come to the aid of their country.
A rat in the house might eat the ice cream.

In other words, I would need to insert a space after the word “for”; but NOT after the word “house.”

[Tinbendr]

Yep, I goofed!

I was interrupted about the time I replied. (I keep telling them I don't have time for their foolishness. But they insist and since I like to eat and stay dry, I guess I have to comply.)

We'll have to move the selection point over one word, and reselect from there to the end of the document.

Insert this just before the bottom loop

With Selection
.Collapse wdCollapseEnd
.MoveStart wdWord
.MoveEnd wdStory
.Select
End With
Loop Until Not Selection.Find.Found


Ya know, this will run lots faster if you moved it over to using Range instead of Selection.

If that interests you, post a sample doc and we'll take a look. (more than you've posted in your text so far. Type =rand(10,4) in a blank doc and set it up with problems.)

[Ice-Tea-Jan]

Tinbendr,

Hello over there in Mississippi!

Definitely your 1st priority is to eat & stay dry!

Thanks again for your prompt re-follow-up!

Yes, I am interested in selecting via ranges instead of selecting to the end of the document because my documents are large.

Attached is a mock sample I just quickly put together for you.

The formatting (highlights & strikethroughs) must stay because they represent insertions & deletions for a special project.

(I know about Word’s track change feature – however, we want simple text with this formatting for a variety of reasons that I won’t to bore you with.)

The various sequences are:

HighlightedStrikethrough (requires a space inserted between)
StrikethroughHighlighted (requires a space inserted between)
Higlighted (requires NO attention--macro should pass over it without adding a space)
Strikethrough (requires NO attention--macro should pass over it without adding a space)If you could sample code something that inserts a space after the highlighted chunks (ONLY when it is jammed up against strikethrough material); then I will try to retrofit/duplicate your code to do the same for the strikethrough chunks (ONLY when it is jammed up against highlighted material).

Any help is you can spare this newbie is appreciated!

Thanks so much for your expertise.

Janet

[Tinbendr]

Wow! That proved to be a little more difficult than I thought.


Sub AddSpaceAfterHighlights()
Dim RngResult As Range
Dim RngToSearch As Range
Dim HighStart As Integer
Dim HighStop As Integer

Set RngToSearch = ActiveDocument.Range
Set RngResult = RngToSearch.Duplicate
Do
With RngResult.Find
.ClearFormatting
.Highlight = True
.Text = ""
.Format = True
.Forward = True
.Wrap = wdFindStop
.Execute
End With

If Not RngResult.Find.Found Then Exit Do
'Store the coordinates for the Found range.
'If we correct it, the coordinates will be
'used to clear the highlight
HighStart = RngResult.Start
HighStop = RngResult.End
'A highlighted range was found. Check rightmost
'character for a space.
Select Case Right(RngResult, 1)

'If rightmost is anything but a space,
'proceed to expand range to check next character.
Case Is <> Chr(32)
'Shrink the range to a single point
RngResult.Collapse wdCollapseEnd
'Extend the range by one character
RngResult.MoveEnd wdCharacter
'Test the one character
Select Case RngResult
'Exclude these.
Case Chr(32), ",", "."

Case Else
'Shrink the range by one character
RngResult.MoveEnd wdCharacter, -1

'Insert space
RngResult.InsertAfter Chr(32)
'Clear Highlight on found range.
ActiveDocument.Range(HighStart, HighStop + 1).HighlightColorIndex = _
wdNoHighlight
End Select
End Select

'This shrinks the range down; one word past last found.
RngResult.MoveStart wdWord
RngResult.End = RngToSearch.End
Loop Until Not RngResult.Find.Found
End Sub

This does leave the Strikethough words butted against the normal text.

Change the .Highlighted = true to .font.strikethrough = true to change those.

[Ice-Tea-Jan]

It appears to add in the space (where applicable); but instead of removing the highlight on just the space, it removes the highlights on the entire selection that it is working on.

I'm hoping this is a simple fix?

[fumei]

Here is an alternative that uses the .Next property of the range. The trickiest part is actually making sure the added space does NOT continue the highlight (or the strikethrough) of the .Found. At least that is what I assume would be desired. If you do not mind the continuation of highlight (or strikethrough) on the inserted space, the code can be shortened.
Option Explicit

Sub FixHighlightStrikethrough()
Dim r As Range
Set r = ActiveDocument.Range
' do the highlight/strikthrough
With r.Find
.ClearFormatting
.Highlight = True
Do While .Execute(Findtext:="", Forward:=True) _
= True
If r.Next(Unit:=wdCharacter, Count:=1) _
.Font.StrikeThrough = True Then
With r
' collapse and insert space
' the space is ALSO highlighted
.Collapse 0
.InsertAfter " "
' so collapse
.Collapse 0
' and move BACK to cover the space
' to make it NOT highlighted
.MoveStart Unit:=wdCharacter, Count:=-1
.HighlightColorIndex = wdNoHighlight
.Collapse 0
End With
End If
Loop
End With
Set r = Nothing
' reset range
Set r = ActiveDocument.Range
' do the strikethrough/highlight
With r.Find
.ClearFormatting
.Font.StrikeThrough = True
Do While .Execute(Findtext:="", Forward:=True) _
= True
If r.Next(Unit:=wdCharacter, Count:=1) _
.HighlightColorIndex <> 0 Then
With r
.Collapse 0
.InsertAfter " "
.Collapse 0
.MoveStart Unit:=wdCharacter, Count:=-1
.Font.StrikeThrough = False
.Collapse 0
End With
End If
Loop
End With
End Sub

Demo attached. Click "Fix Stuff" on the top toolbar.

[Tinbendr]

It appears to add in the space (where applicable); but instead of removing the highlight on just the space, it removes the highlights on the entire selection that it is working on.
:motz2: I thought you'd lost your mind.

:p But I went back and REREAD your first message.

:doh: I just had it in my mind that after it was fixed that it didn't need to be highlighted anymore.

Gerry's solution is also very elegant.

Mine is more 'take three steps forward, then one back.'

Sub AddSpaceAfterHighlights_2()
Dim RngResult As Range
Dim RngToSearch As Range
Dim HighStart As Integer
Dim HighStop As Integer

Set RngToSearch = ActiveDocument.Range
Set RngResult = RngToSearch.Duplicate
Do
With RngResult.Find
.ClearFormatting
.Highlight = True
.Text = ""
.Format = True
.Forward = True
.Wrap = wdFindStop
.Execute
End With

If Not RngResult.Find.Found Then Exit Do
'A highlighted range was found. Check rightmost
'character for a space.
With RngResult
Select Case Right(.Text, 1)
'If rightmost is anything but a space,
'proceed to expand range to check next character.
Case Is <> Chr(32)
'Shrink the range to a single point
.Collapse wdCollapseEnd
'Extend the range by one character
.MoveEnd wdCharacter
'Test the one character
Select Case .Text
'Exclude these.
Case Chr(32), ",", "."

Case Else
'Shrink the range by one character
.MoveEnd wdCharacter, -1

'Insert space
.InsertAfter Chr(32)
.Collapse wdCollapseEnd
.MoveStart wdCharacter, -1
.HighlightColorIndex = wdNoHighlight

End Select
End Select
End With

'This shrinks the range down; one word past last found.
RngResult.MoveStart wdWord
RngResult.End = RngToSearch.End
Loop Until Not RngResult.Find.Found
End Sub

[Ice-Tea-Jan]

Tinbendr & Fumei,

Your both going to murder:eek: me -- but I live far enough away from both of you – so I can get a head start on running in the other direction!!

Can we set it up to loop through all stories in the document?

I tried (unsuccessfully) to wrap this following code around Fumei's code (first before bugging you again); but realized that this would make two ranges set at the same time--?

Dim xRange As Range
For Each xRange In ActiveDocument.StoryRanges
Do
{{your codes placed here}}
Set xRange = xRange.NextStoryRange
Loop Until xRange Is Nothing
Next


Tinbendr: I figured you had intended to rub away the highlighting; and I recognize the process I described was very counter-intuitive.

Both Tinbendr & Fumeii: Please know that I’ve learned something from ALL samples of the coding both of you presented.

I must learn by examples. (BTW: All my learning thus far has been by example, and by flying by the seat of my pants.)

This forum has always been tremendously helpful resource for me. Thank you both for submitting code on real life examples for me to study and absorb.

Janet

[Tinbendr]

Can we set it up to loop through all stories in the document?Sorry once again. Not my best this week. :banghead:

Add/change under the last Dim statement

Dim aStoryRng As Range

For Each aStoryRng In ActiveDocument.StoryRanges

Set RngToSearch = aStoryRng

And at the very bottom, add Next.

[fumei]

"I must learn by examples. (BTW: All my learning thus far has been by example, and by flying by the seat of my pants.)"


That is the way we have ALL done it. There is no formal VBA course from Microsoft. That is why I wrote a two weeks Word VBA course for our in-house use. Trying to make things easier for our in-house people who attempt (for the most part poorly) to use VBA and Word. But it came from the same process as you mention - LOTS and LOTS of trying, and hours upon hours (over years) of looking at examples, and studying the Object Model.

There really is no other way.

May I ask why you need to run through all the Stories? Do you really need to go through them all? After all, there are quite a few.

wdMainTextStory
wdFootnotesStory
wdEndnotesStory
wdCommentsStory
wdTextFrameStory
wdEvenPagesHeaderStory
wdPrimaryHeaderStory
wdEvenPagesFooterStory
wdPrimaryFooterStory
wdFirstPageHeaderStory
wdFirstPageFooterStory

IMO, as 6 of the 11 (more than 50%) are Header/Footer objects, unless you REALLY need to check through Footnotes and Endnotes and Comments, it is much, much, better to be explicit and use HeaderFooter object ranges to action header/footers.

In other words, make a Sub of the actions required, and pass a range object to it.

Sub FixHighlightStrikethrough(r As Range)

' do the highlight/strikthrough
With r.Find
' the actions
......
......
End With
End Sub

Sub DoMyFix()
Dim oSection As Section
Dim oHF As HeaderFooter

' do the main story
Call FixHighlightStrikethrough(ActiveDocument.Range)

' do the headers and footers
For Each oSection In ActiveDocument.Sections
For Each oHF In oSection.Headers
Call FixHighlightStrikethrough(oHF.Range)
Next
For Each oHF In oSection.Footers
Call FixHighlightStrikethrough(oHF.Range)
Next
Next
End Sub

By separating out the actions themselves (Sub FixHighlightStrikethrough) from the top level procedure (Sub DoMyFix), you can perform better debugging.

The actions procedure (Sub FixHighlightStrikethrough) - once debugged - simply takes ANY Range, and does its thing. It makes absolutely no difference WHAT range is passed to it. This makes it more re-useable. For example....

Sub JustTables()
Dim oTable As Table
For Each oTable In ActiveDocument.Tables
Call FixHighlightStrikethrough(oTable.Range)
Next
End Sub
uses the same procedure - because it IS re-useable - to perform the actions on ONLY the tables in the document.

[fumei]

But if you require going through all the StoryRanges, then tinbendr's code will do that. Let me be clear, there is nothing wrong with looping through the StoryRanges. I simply try as much as possible to use explicitness.

[Ice-Tea-Jan]

Once again, thank you both Tinbendr & Fumei,

It is really refreshing to know that my process for learning VBA matches others.

I have a fair amount of books – but only two books that have significantly contributed to my learning.

Tinbendr: Thank you for the code. I will test it, and it looks like I might be able to cross-apply it to other coding.

Fumei: Unfortunately, I do need to send this all through the stories. I’d love to wiggle out of it; however, my documents are chock full of surprises, and can carry many different story types. I need to be thorough with these documents. But I will review and absorb your samples on being explicit.

Many thanks!!!!!!!
Janet

[fumei]

If this thread covers your question sufficiently, please marked it as Solved. Thanks.

[Ice-Tea-Jan]

Timbendr & Fumei,

I tried, but still can’t get this to loop through ALL story ranges-?

This is what I did:

I added Timbendr’s code to fold the for/next around the main code (to step through the different story ranges.)
I THINK I was to supposed to delete the "Set RngToSearch = activedocument.range" (because Tinbendr’s revision restated that as a story range) – correct?
I revised the exclusion (a bit) to exclude a tab and a paragraph mark because I did not want a space between a word and the paragraph mark, and word and a tab.
I copied, and then replaced Tinbendr’s highlight code with a "strikethrough" version of my own.(So now I have two macros: "Final Highlight" & "Final Strikethrough" -- which match each other except for the search terms (one is for highlight, one is for strikethrough).

I set up examples (attached) with different stories & sections, text boxes, odd/even headers, etc.The basic code works, but it does not step through all the stories?
Fumei: I tried (in vain) to step through each Story Range using your code; but I couldn’t get that to fly. (The seat of my pants is pretty thin right now!)

Both codes are pasted below, and also reside in the attached document which contain "ready" samples in order to test both macros.

What am I doing wrong here?:dunno

Here is the code for the highlight:

Sub FinalHighlight()
'
'
Dim RngResult As Range
Dim RngToSearch As Range
Dim HighStart As Integer
Dim HighStop As Integer
'
'__________Tinbendrs Addition
Dim aStoryRng As Range
For Each aStoryRng In ActiveDocument.StoryRanges
Set RngToSearch = aStoryRng
'__________Tinbendrs end of addition
'
'
'Deleted the "Set RngToSearch=activedocument.range
'
'
Set RngResult = RngToSearch.Duplicate
Do
With RngResult.Find
.ClearFormatting
.Highlight = True
.Text = ""
.Format = True
.Forward = True
.Wrap = wdFindStop
.Execute
End With

If Not RngResult.Find.Found Then Exit Do
'A highlighted range was found. Check rightmost
'character for a space.
With RngResult
Select Case Right(.Text, 1)
'If rightmost is anything but a space,
'proceed to expand range to check next character.
Case Is <> Chr(32)
'Shrink the range to a single point
.Collapse wdCollapseEnd
'Extend the range by one character
.MoveEnd wdCharacter
'Test the one character
Select Case .Text
'Exclude these.
Case Chr(32), Chr(13), Chr(9)

Case Else
'Shrink the range by one character
.MoveEnd wdCharacter, -1

'Insert space
.InsertAfter Chr(32)
.Collapse wdCollapseEnd
.MoveStart wdCharacter, -1
.HighlightColorIndex = wdNoHighlight

End Select
End Select
End With

'This shrinks the range down; one word past last found.
RngResult.MoveStart wdWord
RngResult.End = RngToSearch.End
Loop Until Not RngResult.Find.Found
Next
'
'
'
'
End Sub


Here is the code for the strikethrough:

Sub FinalStrikethrough()
'
'
Dim RngResult As Range
Dim RngToSearch As Range
Dim HighStart As Integer
Dim HighStop As Integer
'
'__________Tinbendrs Addition
Dim aStoryRng As Range
For Each aStoryRng In ActiveDocument.StoryRanges
Set RngToSearch = aStoryRng
'__________Tinbendrs end of addition
'
'
'Deleted the "Set RngToSearch=activedocument.range
'
'
Set RngResult = RngToSearch.Duplicate
Do
With RngResult.Find
.ClearFormatting
.Font.StrikeThrough = True
.Font.DoubleStrikeThrough = False
.Text = ""
.Format = True
.Forward = True
.Wrap = wdFindStop
.Execute
End With

If Not RngResult.Find.Found Then Exit Do
'A highlighted range was found. Check rightmost
'character for a space.
With RngResult
Select Case Right(.Text, 1)
'If rightmost is anything but a space,
'proceed to expand range to check next character.
Case Is <> Chr(32)
'Shrink the range to a single point
.Collapse wdCollapseEnd
'Extend the range by one character
.MoveEnd wdCharacter
'Test the one character
Select Case .Text
'Exclude these.
Case Chr(32), Chr(13), Chr(9)

Case Else
'Shrink the range by one character
.MoveEnd wdCharacter, -1

'Insert space
.InsertAfter Chr(32)
.Collapse wdCollapseEnd
.MoveStart wdCharacter, -1
.Font.StrikeThrough = False

End Select
End Select
End With

'This shrinks the range down; one word past last found.
RngResult.MoveStart wdWord
RngResult.End = RngToSearch.End
Loop Until Not RngResult.Find.Found
Next
'
'
'
End Sub

[Tinbendr]

Seems I remember that to access story ranges, you have to be in normal view.

Dim aStoryRng As Range
'Add this line
ActiveDocument.ActiveWindow.View.Type = wdNormalView

For Each aStoryRng In ActiveDocument.StoryRanges
... rest of the code

Then, if you want to change back, at the bottom of the code...
Loop Until Not RngResult.Find.Found
Next
'Add this line
ActiveDocument.ActiveWindow.View.Type = wdPrintView
I suppose the best way to use that would be to record the current view, change to normal, then change back to the previous view.

Dim CurView As Integer
Dim aStoryRng As Range
CurView = ActiveDocument.Range.StoryType
ActiveDocument.ActiveWindow.View.Type = wdNormalView
For Each aStoryRng In ActiveDocument.StoryRanges
'Rest of code
Next

'Last line
ActiveDocument.ActiveWindow.View.Type = CurView

[Ice-Tea-Jan]

Hello Tinbinder,

I placed in your code (as suggested), and it worked on the main document, but it omitted working on any headers beyond the first section.:ipray:

A sample is attached where it seems to work on the text boxes, comments, footnotes, etc. But you will note it does not touch any headers beyond section 1.

I understand the different views available to the end user. However, shouldn’t VB be working "behind the scenes" accessing VB codes, and not relying on whatever the end-user’s view happens to be set at?

Thanking you for all work and attention to this.:ack:

Janet

Here is the code: I only set the initial view to normal, and did not bother to reset it back.


Sub AddSpaceAfterStrikethroughWithViewChange()
'
Dim RngResult As Range
Dim RngToSearch As Range
Dim HighStart As Integer
Dim HighStop As Integer
Dim aStoryRng As Range
'
'____Tinbendr's start/edit (10/5) to help step through story types
ActiveDocument.ActiveWindow.View.Type = wdNormalView
'____Tinbendr's end/edit (10/5) to help step through story types
'
'
For Each aStoryRng In ActiveDocument.StoryRanges
Set RngToSearch = aStoryRng
'
Set RngResult = RngToSearch.Duplicate
Do
With RngResult.Find
.ClearFormatting
.Font.StrikeThrough = True
.Font.DoubleStrikeThrough = False
.Text = ""
.Format = True
.Forward = True
.Wrap = wdFindStop
.Execute
End With

If Not RngResult.Find.Found Then Exit Do
'A strikethough range was found. Check rightmost
'character for a space.
With RngResult
Select Case Right(.Text, 1)
'If rightmost is anything but a space,
'proceed to expand range to check next character.
Case Is <> Chr(32)
'Shrink the range to a single point
.Collapse wdCollapseEnd
'Extend the range by one character
.MoveEnd wdCharacter
'Test the one character
Select Case .Text
'Exclude these (space, paragraph mark, tab).
Case Chr(32), Chr(13), Chr(9)

Case Else
'Shrink the range by one character
.MoveEnd wdCharacter, -1

'Insert space
.InsertAfter Chr(32)
.Collapse wdCollapseEnd
.MoveStart wdCharacter, -1
.Font.StrikeThrough = False

End Select
End Select
End With

'This shrinks the range down; one word past last found.
RngResult.MoveStart wdWord
RngResult.End = RngToSearch.End
Loop Until Not RngResult.Find.Found
Next
'
'
'
'
End Sub

[Ice-Tea-Jan]

Does this require the "nextstoryrange" set somewhere?

:dunno

Regards,
janet

[Tinbendr]

It wasn't the normal view, it was something else. See this link (http://word.mvps.org/faqs/customization/ReplaceAnywhere.htm) for more details.

I'm trying to adapt it, but having trouble with it.

I copied some of the text from the first attachment into the current attachment and it's not correcting everything.

I'll continue to work it, but you might have a go using the code at the link.

[fumei]

Good link, and provides excellent explanations of some of the problems. Especially...

"An example is textbox that is located in a header or footer."

Which is one of the reasons why I dislike textboxes so much.

Janet, could you tell us what, exactly, you are having problems with? WHAT is being missed? You do not say.

BTW: My suggestion about using headerfooter objects and looping through the header and footer collection bypasses the problem mentioned re: headers and footer using StoryRange. Which is why I use it, and why - unless you absolutely have to access the Footnotes and EndNotes and Comments StoryRanges - ....don't use StoryRange.

Also note that acccessing the "text" content inside multiple textboxes can be a nightmare.

[Ice-Tea-Jan]

Basically, (per my post on Oct 5th @ 7:27), the code & sample document there "worked on the main document, but omitted working on any headers beyond the first section."

And in contrast . . .

I tried your ‘DoMyFix" (for headers/footers) to call your version of "FixHighlightStrikethrough" (per your post Oct 1st @ 3:39) -- and that did not even touch any headers/footers???:bug:

Forgive how "newbie" I am.

Thanks
Janet

[Tinbendr]

This seems to work.

Public Sub FindReplaceAnywhere()
Dim rngStory As Word.Range
Dim pFindTxt As String
Dim pReplaceTxt As String
Dim oShp As Shape
'Iterate through all story types in the current document
For Each rngStory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
SearchAll rngStory
On Error Resume Next
Select Case rngStory.StoryType
Case 6, 7, 8, 9, 10, 11
If rngStory.ShapeRange.Count > 0 Then
For Each oShp In rngStory.ShapeRange
If oShp.TextFrame.HasText Then
SearchAll oShp.TextFrame.TextRange
End If
Next
End If
Case Else
'Do Nothing
End Select
On Error GoTo 0
'Get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
End Sub
Public Sub SearchAll(ByVal RngResult As Word.Range)
Dim RngToSearch As Range

Set RngToSearch = RngResult.Duplicate

Do
With RngResult.Find
.ClearFormatting
.Font.StrikeThrough = True
.Font.DoubleStrikeThrough = False
.Text = ""
.Format = True
.Forward = True
.Wrap = wdFindStop
.Execute
End With
If Not RngResult.Find.Found Then Exit Do
'A strikethough range was found. Check rightmost
'character for a space.
With RngResult
'.Select
Select Case Right(.Text, 1)
'If rightmost is anything but a space,
'proceed to expand range to check next character.
Case Is <> Chr(32)
'Shrink the range to a single point
.Collapse wdCollapseEnd
'Extend the range by one character
.MoveEnd wdCharacter
'Test the one character
Select Case .Text
'Exclude these (space, paragraph mark, tab).
Case Chr(32), Chr(13), Chr(9)

Case Else
'Shrink the range by one character
.MoveEnd wdCharacter, -1

'Insert space
.InsertAfter Chr(32)
.Collapse wdCollapseEnd
.MoveStart wdCharacter, -1
.Font.StrikeThrough = False

End Select
End Select
.Collapse wdCollapseEnd
.MoveEnd wdWord
.Start = .End
.End = RngToSearch.End
End With
TheEnd:
Loop Until Not RngResult.Find.Found
End Sub

[Ice-Tea-Jan]

:friends: I'm marking the thread solved. A well-deserved solved indeed!!

This was not an easy request.

I have one more question (for anybody).

How do I look up what story range has which predefined number? I looked through my books, and in the VB editor listing, and can’t seem to find any info.

I’m going to "tinker/duplicate/retrofit" Tinbendr's code (and his follow-up advice) and apply it to the highlighted material.

Thank you Tinbendr (& Fumei) -- all a great help and a fabulous forum for assistance and learning.

Janet

[fumei]

What do you mean by "predefined number"?

I tried your ‘DoMyFix" (for headers/footers) to call your version of "FixHighlightStrikethrough" (per your post Oct 1st @ 3:39) -- and that did not even touch any headers/footers??? My version of FixHighlightStrikethrough as per Oct 1 post...ummmm, did not have full code. I posted:


Sub FixHighlightStrikethrough(r As Range)

' do the highlight/strikthrough
With r.Find
' the actions
......
......
End With
End Sub
No wonder it would not work. Properly coded (i.e. with code) it works on all headers and footers that have their range passed in as a parameter (the r As Range).

[Ice-Tea-Jan]

Fumei,


What do you mean by "predefined number"?


Tinbendr referred to story ranges (Oct 13) code by numbers. He explained how to find their assigned number from VBE.



My version of FixHighlightStrikethrough as per Oct 1 post...ummmm, did not have full code.


Yes, I know. I used your Sept 30 sub "FixHighlightStrikethrough" (alone); and it had a minor kink in it whereby if a blank paragraph mark held any strikethrough formatting -- it would endlessly loop. (Try it in the sample I’ve attached. I made the area in red font so you could zero in on it when you invoke the macro.)

I KNOW one should not use blank paragraph marks! However, I’m dealing with documents from MANY sources, and have NO control over them. People who are not Word savvy use it like a typewriter. (We affectionately call this "Gorilla Word Processing"!)

Anyway, I revised Tinbendr’s code (slightly) to pass over a space, a paragraph mark, or tab.


In other words, make a Sub of the actions required, and pass a range object to it.


I tried to retrofit "DoMy Fix" (Oct 1) (to act upon the headers/footers); and "called" in your full Sept 30 sub "FixHighlightStrikethrough" (?but had to comment out some items?); and it still did not touch the headers/footers? Where did I goof? (I fully recognize that I know enough to get me in trouble.)

That code is below, and in the document itself. (When I tested it, I removed that one blank strikethrough paragraph to stop the endless loop just to see if that was "holding up" the work on the header/footer—but that did not do a thing.)

I’m willing to bet that I screwed up your "DoMyFix" somehow – but that is for you tell me.:(

Janet



Option Explicit

Sub FixHighlightStrikethrough(r As Range)
' Commented out: Dim r As Range
' Commented out: Set r = ActiveDocument.Range
' do the highlight/strikthrough
With r.Find
.ClearFormatting
.Highlight = True
Do While .Execute(Findtext:="", Forward:=True) _
= True
If r.Next(Unit:=wdCharacter, Count:=1) _
.Font.StrikeThrough = True Then
With r
' collapse and insert space
' the space is ALSO highlighted
.Collapse 0
.InsertAfter " "
' so collapse
.Collapse 0
' and move BACK to cover the space
' to make it NOT highlighted
.MoveStart Unit:=wdCharacter, Count:=-1
.HighlightColorIndex = wdNoHighlight
.Collapse 0
End With
End If
Loop
End With
Set r = Nothing
' reset range
Set r = ActiveDocument.Range
' do the strikethrough/highlight
With r.Find
.ClearFormatting
.Font.StrikeThrough = True
Do While .Execute(Findtext:="", Forward:=True) _
= True
If r.Next(Unit:=wdCharacter, Count:=1) _
.HighlightColorIndex <> 0 Then
With r
.Collapse 0
.InsertAfter " "
.Collapse 0
.MoveStart Unit:=wdCharacter, Count:=-1
.Font.StrikeThrough = False
.Collapse 0
End With
End If
Loop
End With
End Sub
Sub DoMyFix()
Dim oSection As Section
Dim oHF As HeaderFooter
'
' do the main story
Call FixHighlightStrikethrough(ActiveDocument.Range)
'
'
' do the headers and footers
For Each oSection In ActiveDocument.Sections
For Each oHF In oSection.Headers
Call FixHighlightStrikethrough(oHF.Range)
Next
For Each oHF In oSection.Footers
Call FixHighlightStrikethrough(oHF.Range)
Next
Next
End Sub