How to delete ALL Words EXCEPT <specified format>

[JS]

Hi all,

I've bumped into an interesting challenge - how to delete all text in a file
except certain types of formatted text. I came up with a VBA solution (only
for highlighted text) [conde listed below], but it is clumsy, unelegent and
SOOOOO SLOOOOW [can take hours!!!]....
Does anyone have a better idea/solution they might want to share?
Thanks in advance for your help!!! Rgds, JS

=============================
Sub DeleteALLWordsEXCEPTHighlight()
Dim xxx As Long
' need to set all paragraph marks to highlighted, otherwise they are deleted
below
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Highlight = True
With Selection.Find
.Text = "^p"
.Replacement.Text = "^p"
.Forward = False
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'
Selection.WholeStory
For xxx = Selection.Words.Count To 2 Step -1
If Selection.Words(xxx).HighlightColorIndex <> wdYellow Then ' note:
Words(xxx) also bring paragraph marks!!!
' MsgBox Selection.Words(xxx)
Selection.Words(xxx).Select
Selection.Delete
Selection.WholeStory
End If
Next
End Sub
========================================

 

[Greg Maxey]

JS,

Perhaps:

Sub Test()
Dim oRng As Word.Range
Set oRng = ActiveDocument.Range
With oRng.Find
.Highlight = False
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With
End Sub

 

[Helmut Weber]

Hi JS,

often it is the question, which is the problem,
not the answer. Don't delete anything at all.
Create a new doc. Transpose the text in question.
Otherwise see Greg's answer.

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

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

 

[JS]

Hi Greg - Thanks a million - works like a charm and is much, much faster
than my code
I just had to add replace all paragraph marks to highlight, otherwise they
get deleted (jumbles the text) - the final code is below:

Quick question - I've tried to substitute the ".Highlight = False" for
".Shading = False" (to delete all except shading) but this does not work -
could you please give me another tip here - thanks and sorry to abuse of
your kindnee.
Rgds, JS

Sub DeleteAllTextEXCEPT_Highlight_2()
Dim oRng As Word.Range
' ====================== Added so as not to delete paragraph marks
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Highlight = True
With Selection.Find
.Text = "^p"
.Replacement.Text = "^p"
.Forward = False
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
' =================================
Set oRng = ActiveDocument.Range
With oRng.Find
.Highlight = False
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With
End Sub

JS,

Perhaps:

Sub Test()
Dim oRng As Word.Range
Set oRng = ActiveDocument.Range
With oRng.Find
.Highlight = False
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With
End Sub

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

Hi all,

I've bumped into an interesting challenge - how to delete all text in
a file except certain types of formatted text. I came up with a VBA
solution (only for highlighted text) [conde listed below], but it is
clumsy, unelegent and SOOOOO SLOOOOW [can take hours!!!]....
Does anyone have a better idea/solution they might want to share?
Thanks in advance for your help!!! Rgds, JS

=============================
Sub DeleteALLWordsEXCEPTHighlight()
Dim xxx As Long
' need to set all paragraph marks to highlighted, otherwise they are
deleted below
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Highlight = True
With Selection.Find
.Text = "^p"
.Replacement.Text = "^p"
.Forward = False
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'
Selection.WholeStory
For xxx = Selection.Words.Count To 2 Step -1
If Selection.Words(xxx).HighlightColorIndex <> wdYellow Then ' note:
Words(xxx) also bring paragraph marks!!!
' MsgBox Selection.Words(xxx)
Selection.Words(xxx).Select
Selection.Delete
Selection.WholeStory
End If
Next
End Sub
========================================

 

[JS]

Hi Helmut:

Thank you for your reply - I sort of had that idea, but: 1) I'm not
familiar with transposing (looked this up in word vba held but didn't find
this property/method...); 2) I would think this is like excel - if you copy
multiple selections to somewhere else, they all collapse thus losing the
original structure/format - But I'm more than willing to try, can you please
point me toward / give we a tip on how to do this?

Again, thanks for your input
Rgds from Brazil

 

[Helmut Weber]

Hi JS,

have a look at this one:

Sub test000011()
Dim oDcmSrc As Document ' source document
Dim oDcmTrg As Document ' target document
Dim rDcmSrc As Range ' source range
Dim rDcmTrg As Range ' target range
Set oDcmSrc = Documents("c:\test\source.doc")
Set oDcmTrg = Documents("c:\test\target.doc")
Set rDcmSrc = oDcmSrc.Range
Set rDcmTrg = oDcmTrg.Range
With rDcmSrc.Find
.Font.Shadow = True
While .Execute
rDcmTrg.InsertAfter rDcmSrc.Text & vbCr
Wend
End With
End Sub

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

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

 

[JS]

Hi Helmut:
I wish to thank you for your suggestion and input.
By using your seed example, I've put together code that will extract
selected formats from multiple files (code below).
Again, thanks for your help - Rgds, JS
===============================
Sub Copy2NewFileAllLavenderText()
Dim TgtDocRng As Range
Dim SrsDocRng(1 To 20) As Range
Dim NumDocs As Long

For NumDocs = 1 To Documents.Count
Documents(NumDocs).Activate
Selection.WholeStory
Set SrsDocRng(NumDocs) = Selection.Range
Next
Documents.Add
Selection.WholeStory
Set TgtDocRng = Selection.Range

For NumDocs = 1 To Documents.Count - 1
With SrsDocRng(NumDocs).Find
.Font.Color = wdColorLavender
While .Execute
TgtDocRng.InsertAfter SrsDocRng(NumDocs).Text & vbCr
Wend
End With
TgtDocRng.InsertAfter "{+}" & vbCr
Next
End Sub
==========================================

 

[Russ]

JS,
As an exercise on a very useful subroutine, I altered your subroutine to use
ranges only and to list in the order the files were opened. It works well
for me.
Thanks to you and Helmut.


Sub Copy2NewFileAllLavenderText()
Dim TgtDocRng As Range
Dim NumDocs As Long

ReDim SrsDocRng(Documents.Count) As Range

Documents.Add
Set TgtDocRng = ActiveDocument.Range

For NumDocs = Documents.Count - 2 To 0 Step -1
Set SrsDocRng(NumDocs) = Documents(NumDocs + 2).Range
With SrsDocRng(NumDocs).Find
.Font.Color = wdColorLavender
While .Execute
TgtDocRng.InsertAfter SrsDocRng(NumDocs).Text & vbCr
Wend
End With
TgtDocRng.InsertAfter "{+}" & vbCr
Next
End Sub