Copy all hilighted words to a new document using VBA

[andreas]

Dear Experts:

I would like to copy all hilighted words of the current document (via
VBA) to a new one with the following features:

1. Highlighted word
2. Page No. where the highlighted word has been found
3. Applied Font of the highlighted word

If a word has only be hilighted partially, the whole word has to be
copied.

Example:

going (highlighted word), Page 219, Font Name: Arial
Christmas (highlighted word), Page 222, Font Name: Tahoma.
etc.


Hope this is not asking too much and feasible, respectively.

Help is much appreciated. Thank you very much in advance.

Regards, Andreas

 

[Graham Mayor]

How about

Dim oRng As Range
Dim oSource As Document
Dim oDoc As Document
Dim iPage As Integer
Dim sFont As String
Set oSource = ActiveDocument
Set oDoc = Documents.Add
oSource.Activate
With Selection
.HomeKey Unit:=wdStory
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Highlight = True
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
Do While .Execute = True
Set oRng = Selection.Range
With oRng
.Start = .Words.First.Start
.End = .Words.Last.End - 1
sFont = .Font.name
iPage = .Information(wdActiveEndPageNumber)
oDoc.Range.InsertAfter oRng.Text & _
", Page " & _
iPage & ", Name: " _
& sFont & vbCr
End With
Loop
End With
End With
With oDoc.Range
.Paragraphs.Last.Range.Delete
.Style = "Normal"
End With
oDoc.Activate


--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

 

[andreas]

How about

Dim oRng As Range
Dim oSource As Document
Dim oDoc As Document
Dim iPage As Integer
Dim sFont As String
Set oSource = ActiveDocument
Set oDoc = Documents.Add
oSource.Activate
With Selection
    .HomeKey Unit:=wdStory
    With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = ""
        .Highlight = True
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        Do While .Execute = True
            Set oRng = Selection.Range
            With oRng
                .Start = .Words.First.Start
                .End = .Words.Last.End - 1
                sFont = .Font.name
                iPage = .Information(wdActiveEndPageNumber)
                oDoc.Range.InsertAfter oRng.Text & _
                ", Page " & _
                iPage & ", Name: " _
                & sFont & vbCr
            End With
        Loop
    End With
End With
With oDoc.Range
    .Paragraphs.Last.Range.Delete
    .Style = "Normal"
End With
oDoc.Activate

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor -  Word MVP

My web sitewww.gmayor.com
Word MVP web sitehttp://word.mvps.org
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>












- Zitierten Text anzeigen -

Hi Graham,

Great coding! Thank you very much for your terrific help. It works
although I would like the macro to be changed slightly.

The hilighted words that have been copied into the new document should
also feature the highlighting in the new document. Is that possible?
This feature will allow me to check whether there are words that have
only been partially highlighted.

If this is feasible then it would be even more practical if in cases
where partial highlighting has been applied, a statement would say so.
Example:

Reconstructive, Page 1, Times New Roman, partly highlighted.
Surgery, Page 1, Times New Roman

Hope this is not asking too much. Help is much appreciated. Thank you
very much in advance.

Regards, Andreas


Help is much appreciated. Thank you very much in advance. Regards,
Andreas

 

[Graham Mayor]

It is starting to get ugly (and slower), but the following may help

Dim oRng As Range
Dim oNRng As Range
Dim oSource As Document
Dim oDoc As Document
Dim iPage As Integer
Dim iLen As Integer
Dim iPara As Integer
Dim sFont As String
Dim sComp As String
Dim sWords As String
Dim sColor As WdColor
Set oSource = ActiveDocument
Set oDoc = Documents.Add
oSource.Activate
With Selection
.HomeKey Unit:=wdStory
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Highlight = True
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
Do While .Execute = True
Set oRng = Selection.Range
With oRng
sColor = .HighlightColorIndex
If .Start <> .Words.First.Start Or _
.End <> .Words.Last.End - 1 Then
sComp = ", Partly highlighted"
Else
sComp = ""
End If
.Start = .Words.First.Start
.End = .Words.Last.End - 1
.Copy
sFont = .Font.name
iPage = .Information(wdActiveEndPageNumber)
oDoc.Range.InsertAfter oRng.Text & _
", Page " & _
iPage & ", Name: " _
& sFont & sComp & vbCr
iPara = oDoc.Paragraphs.Count - 1
iLen = InStr(1, oDoc.Paragraphs(iPara).Range.Text, ",")
For i = 1 To iLen - 1
oDoc.Paragraphs(iPara).Range.Characters(i).HighlightColorIndex
= sColor
Next i
End With
Loop
End With
End With
With oDoc.Range
.Paragraphs.Last.Range.Delete
End With
oDoc.Activate


--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

How about

Dim oRng As Range
Dim oSource As Document
Dim oDoc As Document
Dim iPage As Integer
Dim sFont As String
Set oSource = ActiveDocument
Set oDoc = Documents.Add
oSource.Activate
With Selection
.HomeKey Unit:=wdStory
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Highlight = True
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
Do While .Execute = True
Set oRng = Selection.Range
With oRng
.Start = .Words.First.Start
.End = .Words.Last.End - 1
sFont = .Font.name
iPage = .Information(wdActiveEndPageNumber)
oDoc.Range.InsertAfter oRng.Text & _
", Page " & _
iPage & ", Name: " _
& sFont & vbCr
End With
Loop
End With
End With
With oDoc.Range
.Paragraphs.Last.Range.Delete
.Style = "Normal"
End With
oDoc.Activate

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP

My web sitewww.gmayor.com
Word MVP web sitehttp://word.mvps.org
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>












- Zitierten Text anzeigen -

Hi Graham,

Great coding! Thank you very much for your terrific help. It works
although I would like the macro to be changed slightly.

The hilighted words that have been copied into the new document should
also feature the highlighting in the new document. Is that possible?
This feature will allow me to check whether there are words that have
only been partially highlighted.

If this is feasible then it would be even more practical if in cases
where partial highlighting has been applied, a statement would say so.
Example:

Reconstructive, Page 1, Times New Roman, partly highlighted.
Surgery, Page 1, Times New Roman

Hope this is not asking too much. Help is much appreciated. Thank you
very much in advance.

Regards, Andreas


Help is much appreciated. Thank you very much in advance. Regards,
Andreas

 

[DaveLett]

Hi all,
I was reading/testing Graham's post to see if I could learn something new,
and I think I might have found a couple of issues, which are probably just
rare occurrences anyway.

1) The line ".End = .Words.Last.End - 1" presumes (I think) that the word
ends with a space after it. When I run the routine in a test document, any
word that is highlighted and followed by a punctuation mark or paragraph, the
routine reports as partially highlighted.

2) In the very outside chance the that highlighted word is actually a group
of words, then the routine doesn't "report" the font name.

All of this is just FYI and FWIW,

Dave

 

[Graham Mayor]

That first possibility occurred to me after I posted, but I was going out to
a festive party, so I did not pursue it further. Now back, with a hangover,
I might be inclined to explore it further.

Regarding the second point, I took the OP at his word that he meant 'word'
and not 'words' (always a risky thing to do), but felt it possible that
there may be a couple of words and I allowed for that. The macro should
report the font name, though hopefully there would not be more than one font
in the range.

They were not the only problems I could think of either. I suspect that the
OP wants the highlighted word formatted as it appears in the document when
it is reproduced in the extract. This is fiddly to achieve without copy and
paste - and in any case then I wonder at the point of it. If the plan was to
identify words that had not been completely highlighted it would be simpler
to correct that with the macro before extracting the data and have no
partially formatted words.

I'll wait and see what the OP has to say before playing further - to give
the hangover time to fade - when we might learn the point of the
exercise, which might then point to a different approach entirely.

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

 

[andreas]

That first possibility occurred to me after I posted, but I was going outto
a festive party, so I did not pursue it further. Now back, with a hangover,
I might be inclined to explore it further.

Regarding the second point, I took the OP at his word that he meant 'word'
and not 'words' (always a risky thing to do), but felt it possible that
there may be a couple of words and I allowed for that. The macro should
report the font name, though hopefully there would not be more than one font
in the range.

They were not the only problems I could think of either. I suspect that the
OP wants the highlighted word formatted as it appears in the document when
it is reproduced in the extract. This is fiddly to achieve without copy and
paste - and in any case then I wonder at the point of it. If the plan wasto
identify words that had not been completely highlighted it would be simpler
to correct that with the macro before extracting the data and have no
partially formatted words.

I'll wait and see what the OP has to say before playing further - to give
the hangover time to fade - when we might learn the point of the
exercise, which might then point to a different approach entirely.

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor -  Word MVP

My web sitewww.gmayor.com
Word MVP web sitehttp://word.mvps.org
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>










- Zitierten Text anzeigen -

Hi Graham and Dave,

I am really very impressed by the professionalism with which you
tackle/sort out VBA problems. This forum is more than terrific.

I am getting back soon with a detailed analysis.

Regards, Andreas

 

[Graham Mayor]

The following takes care of the issues raised by Dave and the one I raised
myself. It gets no prizes for elegant coding, but should do the job?

Dim oRng As Range
Dim oNRng As Range
Dim oSource As Document
Dim oDoc As Document
Dim iPage As Integer
Dim iLen As Integer
Dim iPara As Integer
Dim iIst As Integer
Dim iLast As Integer
Dim sFont As String
Dim sComp As String
Dim sNext As String
Dim sWords As String
Dim sColor As WdColor
Set oSource = ActiveDocument
Set oDoc = Documents.Add
oSource.Activate
With Selection
.HomeKey Unit:=wdStory
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Highlight = True
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
Do While .Execute = True
Set oRng = Selection.Range
With oRng
iIst = .Start - .Words.First.Start + 1
iLast = .Words.Last.End - .End
sNext = .Next.Characters(1)
sColor = .HighlightColorIndex
If .Start <> .Words.First.Start Or _
.End <> .Words.Last.End - 1 And _
sNext <> "" Then
Select Case sNext
Case ",", ".", "?", "!", ":", ";"
sComp = ""
iLast = iLast + 1
Case Else
sComp = ", Partly highlighted"
End Select
Else
sComp = ""
End If
.Start = .Words.First.Start
.End = .Words.Last.End
If .Characters.Last = Chr(32) Then
.End = .Words.Last.End - 1
End If
.Copy
sFont = .Font.name
iPage = .Information(wdActiveEndPageNumber)
oDoc.Range.InsertAfter oRng.Text & _
", Page " & _
iPage & ", Name: " _
& sFont & sComp & vbCr
iPara = oDoc.Paragraphs.Count - 1
iLen = InStr(1, oDoc.Paragraphs(iPara).Range.Text, ",")
For i = iIst To iLen - iLast
oDoc.Paragraphs(iPara).Range.Characters(i).HighlightColorIndex
= sColor
Next i
End With
Loop
End With
End With
With oDoc.Range
.Paragraphs.Last.Range.Delete
End With
oDoc.Activate


--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

That first possibility occurred to me after I posted, but I was going out
to
a festive party, so I did not pursue it further. Now back, with a
hangover,
I might be inclined to explore it further.

Regarding the second point, I took the OP at his word that he meant 'word'
and not 'words' (always a risky thing to do), but felt it possible that
there may be a couple of words and I allowed for that. The macro should
report the font name, though hopefully there would not be more than one
font
in the range.

They were not the only problems I could think of either. I suspect that
the
OP wants the highlighted word formatted as it appears in the document when
it is reproduced in the extract. This is fiddly to achieve without copy
and
paste - and in any case then I wonder at the point of it. If the plan was
to
identify words that had not been completely highlighted it would be
simpler
to correct that with the macro before extracting the data and have no
partially formatted words.

I'll wait and see what the OP has to say before playing further - to give
the hangover time to fade - when we might learn the point of the
exercise, which might then point to a different approach entirely.

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP

My web sitewww.gmayor.com
Word MVP web sitehttp://word.mvps.org
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>










- Zitierten Text anzeigen -

Hi Graham and Dave,

I am really very impressed by the professionalism with which you
tackle/sort out VBA problems. This forum is more than terrific.

I am getting back soon with a detailed analysis.

Regards, Andreas

 

[Greg Maxey]

Graham,

Seeking no prizes either and just offering a different slant. I notice in
your version you include a ".copy" but not a paste. Using a paste and a
little fiddling with the range you can duplicate the formatting in the
document (if as you say there is a point or need for that).

Sub ScratchMaco()
Dim oSource As Word.Document, oListDoc As Word.Document
Dim oRng As Word.Range, oListRng As Word.Range
Dim sFont As String, sComp As String
Dim sNext As String, sPrevious As String
Dim bCompStart As Boolean, bCompEnd As Boolean
Dim iPage As Long
Set oSource = ActiveDocument
Set oListDoc = Documents.Add
Set oListRng = oListDoc.Range
oSource.Activate
oSource.Range(0, 0).Select
Set oRng = oSource.Range
With oRng
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Highlight = True
.Forward = True
.Wrap = wdFindStop
.Format = True
Do While .Execute = True
With oRng
bCompStart = False
bCompEnd = False
On Error Resume Next
sPrevious = oRng.Characters.First.Previous
'Errors if range start is at beginning of document (no previous
character exists).
If Err.Number = 91 Then
bCompStart = True
Else
Select Case sPrevious
'Previous charactesr is a space, tab, or paragraph mark or line
feed.
Case Chr(32), Chr(13), Chr(11), Chr(10), Chr(9)
bCompStart = True
Case Else
'Do nothing
End Select
End If
On Error GoTo 0
sNext = oRng.Characters.Last.Next
Select Case sNext
Case ",", ".", "?", "!", ":", ";", " "
bCompEnd = True
Case Chr(13), Chr(11), Chr(10), Chr(9)
bCompEnd = True
Case Else
'Do nothing
End Select
If bCompStart And bCompEnd Then
sComp = ""
Else
sComp = ", partially highlighted"
End If
sFont = .Font.Name
If Len(sFont) < 1 Then sFont = "Mixed fonts detected. Name not
determined."
iPage = .Information(wdActiveEndPageNumber)
.Start = .Words.First.Start
.End = .Words.Last.End
.Copy
.Collapse wdCollapseEnd
With oListRng
.Collapse wdCollapseEnd
.InsertAfter ","
.End = .End - 1
.Paste
.Start = .End + 1
.Text = " Page " & iPage & ", Name: " & sFont & sComp & vbCr
.HighlightColorIndex = wdAuto
End With
End With
Loop
End With
End With
oListDoc.Range.Paragraphs.Last.Range.Delete
oListDoc.Activate
End Sub

 

[Greg Maxey]

I think my first attempt involved some over kill as I was half way through
it before I realized the OP wanted to list the whole of partically
highlighted words. Rev 2:

Sub ScratchMaco()
Dim oSource As Word.Document, oListDoc As Word.Document
Dim oRng As Word.Range, oListRng As Word.Range
Dim sFont As String, sComp As String
Dim bCompStart As Boolean, bCompEnd As Boolean
Dim iPage As Long
Set oSource = ActiveDocument
Set oListDoc = Documents.Add
Set oListRng = oListDoc.Range
oSource.Activate
oSource.Range(0, 0).Select
Set oRng = oSource.Range
With oRng
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Highlight = True
.Forward = True
.Wrap = wdFindStop
.Format = True
Do While .Execute = True
With oRng
bCompStart = False
bCompEnd = False
If .Start = .Words(1).Start Then bCompStart = True
If .End = .Words(.Words.Count).End Then bCompEnd = True
sComp = ""
If Not bCompStart Or Not bCompEnd Then sComp = ", partially
highlighted"
sFont = .Font.Name
If Len(sFont) < 1 Then sFont = "Mixed fonts detected and a specific
name is not determined"
iPage = .Information(wdActiveEndPageNumber)
.Start = .Words.First.Start
.End = .Words.Last.End
.Copy
.Collapse wdCollapseEnd
With oListRng
.Collapse wdCollapseEnd
.InsertAfter ","
.End = .End - 1
.Paste
.Start = .End + 1
.Text = " Page " & iPage & ", Name: " & sFont & sComp & vbCr
.HighlightColorIndex = wdAuto
End With
End With
Loop
End With
End With
oListDoc.Range.Paragraphs.Last.Range.Delete
oListDoc.Activate
End Sub

 

[Graham Mayor]

The .Copy was an artifact from an earlier iteration of the macro while
testing. I was seeking to copy the formatted text to the target document, so
as not to have to reformat it later as you correctly surmise - but I later
chose not to and the .Copy line was overlooked. It does nothing useful and
can be deleted.
The whole thing was merely an exercise to pass the time on a particularly
quiet day.
--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

 

[Graham Mayor]

While the font name trap line is a handy addition, your version of the macro
marks all the highlighted words in my test sample as partially highted -
back to the drawing board

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

 

[Greg Maxey]

Graham,

Yep you are right. I trimmed to much and was using poor example text.
Culprit was the trailing space character in the .Word.Range. This should
sort it out:

Sub ScratchMaco()
Dim oSource As Word.Document, oListDoc As Word.Document
Dim oRng As Word.Range, oListRng As Word.Range
Dim sFont As String, sComp As String
Dim bCompStart As Boolean, bCompEnd As Boolean
Dim iPage As Long
Set oSource = ActiveDocument
Set oListDoc = Documents.Add
Set oListRng = oListDoc.Range
oSource.Activate
oSource.Range(0, 0).Select
Set oRng = oSource.Range
With oRng
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Highlight = True
.Forward = True
.Wrap = wdFindStop
.Format = True
Do While .Execute = True
With oRng
bCompStart = False
bCompEnd = False
If .Start = .Words(1).Start Then bCompStart = True
.Start = .Words.First.Start
Select Case .Words(.Words.Count).Characters.Last
Case Is = Chr(32)
If .End = .Words(.Words.Count).End - 1 Then bCompEnd = True
Case Else
If .End = .Words(.Words.Count).End Then bCompEnd = True
.End = .Words.Last.End
End Select
sComp = ""
If Not bCompStart Or Not bCompEnd Then sComp = ", partially
highlighted"
sFont = .Font.Name
If Len(sFont) < 1 Then sFont = "Mixed fonts detected and a specific
name is not determined"
iPage = .Information(wdActiveEndPageNumber)
.Copy
.Collapse wdCollapseEnd
With oListRng
.Collapse wdCollapseEnd
.InsertAfter ","
.End = .End - 1
.Paste
.Start = .End + 1
.Text = " Page " & iPage & ", Name: " & sFont & sComp & vbCr
.HighlightColorIndex = wdAuto
End With
End With
Loop
End With
End With
oListDoc.Range.Paragraphs.Last.Range.Delete
oListDoc.Activate
End Sub

 

[DaveLett]

Hi,
Just out of curiosity...
Would it be more efficient to use .FormattedText on the range objects
instead of .Copy and .Paste? From my test, doing so would change the
following:

iPage = .Information(wdActiveEndPageNumber)
..Copy
..Collapse wdCollapseEnd
With oListRng
..Collapse wdCollapseEnd
..InsertAfter ","
..End = .End - 1
..Paste
..Start = .End + 1
..Text = " Page " & iPage & ", Name: " & sFont & sComp & vbCr
..HighlightColorIndex = wdAuto
End With

To the following:
iPage = .Information(wdActiveEndPageNumber)
With oListRng
..Collapse wdCollapseEnd
..FormattedText = oRng.FormattedText
..Start = .End + 1
..InsertAfter Text:=", Page " & iPage & ", Name: " & sFont & sComp & vbCr
..HighlightColorIndex = wdAuto
End With
..Collapse wdCollapseEnd

Thanks,
Dave

 

[Graham Mayor]

That works too, but whether it is any more efficient than Greg's method or
mine, I hestitate to guess. Certainly there is little difference in speed on
my test sample, but that doesn't run to a couple of hundred pages like that
of the OP. It just shows that there is more than one way to skin a rabbit.
At the end of the day I will settle for code that works - polishing cannon
balls is Greg's forte

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

 

[Graham Mayor]

Using FormattedText did however resolve a problem I was having getting the
macro to format the text correctly in a table cell. I don't know why I
didn't consider it earlier

Using the table does seem noticably faster.

Can you tell it's the slack period twixt Christmas and New Year?

Dim oRng, oNrng As Range
Dim oSource, oDoc As Document
Dim oTable As Table
Dim iRow, iPage, ILen As Integer
Dim iPara, iIst, iLast As Integer
Dim sFont, SComp, sNext, sWords As String
Dim sColor As WdColor
Set oSource = ActiveDocument
Set oDoc = Documents.Add
Set oTable = oDoc.Tables.Add(oDoc.Range, 2, 4)
With oTable
.Cell(1, 1).Range.Text = "Highlighted Text"
.Cell(1, 2).Range.Text = "Page"
.Cell(1, 3).Range.Text = "Font"
.Cell(1, 4).Range.Text = "Comments"
With .Rows(1).Range
.ParagraphFormat.Alignment = _
wdAlignParagraphCenter
.Font.name = "Arial"
.Font.Size = "12"
.Bold = True
End With
End With
oSource.Activate
With Selection
.HomeKey Unit:=wdStory
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Highlight = True
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
Do While .Execute = True
Set oRng = Selection.Range
With oRng
iIst = .Start - .Words.First.Start + 1
iLast = .Words.Last.End - .End
sNext = .Next.Characters(1)
'sColor = .HighlightColorIndex
If .Start <> .Words.First.Start Or _
.End <> .Words.Last.End - 1 And _
sNext <> "" Then
Select Case sNext
Case ",", ".", "?", "!", ":", ";"
SComp = ""
iLast = iLast + 1
Case Else
SComp = "Partly highlighted"
End Select
Else
SComp = ""
End If
.Start = .Words.First.Start
.End = .Words.Last.End
If .Characters.Last = Chr(32) Then
.End = .Words.Last.End - 1
End If
sFont = .Font.name
If Len(sFont) < 1 Then sFont = "Mixed fonts detected"
iPage = .Information(wdActiveEndPageNumber)
iRow = oTable.Rows.Count
oTable.Cell(iRow, 1).Range.FormattedText =
oRng.FormattedText
oTable.Cell(iRow, 2).Range.Text = iPage
oTable.Cell(iRow, 2).Range.ParagraphFormat.Alignment _
= wdAlignParagraphCenter
oTable.Cell(iRow, 3).Range.Text = sFont
oTable.Cell(iRow, 4).Range.Text = SComp
oTable.Rows.Add
End With
Loop
End With
End With
oTable.Rows.Last.Delete
oDoc.Activate

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

 

[andreas]

Using FormattedText did however resolve a problem I was having getting the
macro to format the text correctly in a table cell. I don't know why I
didn't consider it earlier

Using the table does seem noticably faster.

Can you tell it's the slack period twixt Christmas and New Year?

Dim oRng, oNrng As Range
Dim oSource, oDoc As Document
Dim oTable As Table
Dim iRow, iPage, ILen As Integer
Dim iPara, iIst, iLast As Integer
Dim sFont, SComp, sNext, sWords As String
Dim sColor As WdColor
Set oSource = ActiveDocument
Set oDoc = Documents.Add
Set oTable = oDoc.Tables.Add(oDoc.Range, 2, 4)
With oTable
    .Cell(1, 1).Range.Text = "Highlighted Text"
    .Cell(1, 2).Range.Text = "Page"
    .Cell(1, 3).Range.Text = "Font"
    .Cell(1, 4).Range.Text = "Comments"
    With .Rows(1).Range
        .ParagraphFormat.Alignment = _
            wdAlignParagraphCenter
        .Font.name = "Arial"
        .Font.Size = "12"
        .Bold = True
    End With
End With
oSource.Activate
With Selection
    .HomeKey Unit:=wdStory
    With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = ""
        .Highlight = True
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        Do While .Execute = True
            Set oRng = Selection.Range
            With oRng
                iIst = .Start - .Words.First.Start + 1
                iLast = .Words.Last.End - .End
                sNext = .Next.Characters(1)
                'sColor = .HighlightColorIndex
                If .Start <> .Words.First.Start Or _
                    .End <> .Words.Last.End - 1 And _
                    sNext <> "" Then
                    Select Case sNext
                        Case ",", ".", "?", "!", ":", ";"
                            SComp = ""
                            iLast = iLast +1
                        Case Else
                            SComp = "Partlyhighlighted"
                    End Select
                Else
                    SComp = ""
                End If
                .Start = .Words.First.Start
                .End = .Words.Last.End
                If .Characters.Last = Chr(32) Then
                    .End = .Words.Last.End - 1
                End If
                sFont = .Font.name
                If Len(sFont) < 1 Then sFont = "Mixed fonts detected"
                iPage = .Information(wdActiveEndPageNumber)
                iRow = oTable.Rows.Count
                oTable.Cell(iRow, 1).Range.FormattedText =
oRng.FormattedText
                oTable.Cell(iRow, 2).Range.Text = iPage
                oTable.Cell(iRow, 2).Range.ParagraphFormat.Alignment _
                    = wdAlignParagraphCenter
                oTable.Cell(iRow, 3).Range.Text = sFont
                oTable.Cell(iRow, 4).Range.Text = SComp
                oTable.Rows.Add
            End With
        Loop
    End With
End With
oTable.Rows.Last.Delete
oDoc.Activate

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor -  Word MVP

My web sitewww.gmayor.com
Word MVP web sitehttp://word.mvps.org
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>









- Zitierten Text anzeigen -

To all of you (especially Graham and Greg, as well as Dave).

What shall I say? I am so impressed by your skills!! Exactly what I
wanted!! You two truly deserve the MVP designation.
Graham's code serves my purpose a little better since partially
highlighted words get copied and pasted completely (that is not just
the highlighted part, but the whole word).

Anyway. Great coding!! You three have a really nice new year's eve and
all the best for 2010 from an enthusiastic user of this forum.

Regards, Andreas

 

[andreas]

Graham,

Yep you are right.  I trimmed to much and was using poor example text.
Culprit was the trailing space character in the .Word.Range.  This should
sort it out:

Sub ScratchMaco()
Dim oSource As Word.Document, oListDoc As Word.Document
Dim oRng As Word.Range, oListRng As Word.Range
Dim sFont As String, sComp As String
Dim bCompStart As Boolean, bCompEnd As Boolean
Dim iPage As Long
Set oSource = ActiveDocument
Set oListDoc = Documents.Add
Set oListRng = oListDoc.Range
oSource.Activate
oSource.Range(0, 0).Select
Set oRng = oSource.Range
With oRng
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Highlight = True
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    Do While .Execute = True
      With oRng
        bCompStart = False
        bCompEnd = False
        If .Start = .Words(1).Start Then bCompStart = True
        .Start = .Words.First.Start
        Select Case .Words(.Words.Count).Characters.Last
          Case Is = Chr(32)
            If .End = .Words(.Words.Count).End - 1 Then bCompEnd = True
          Case Else
            If .End = .Words(.Words.Count).End Then bCompEnd = True
            .End = .Words.Last.End
        End Select
        sComp = ""
        If Not bCompStart Or Not bCompEnd Then sComp = ", partially
highlighted"
        sFont = .Font.Name
        If Len(sFont) < 1 Then sFont = "Mixed fonts detected and a specific
name is not determined"
        iPage = .Information(wdActiveEndPageNumber)
        .Copy
        .Collapse wdCollapseEnd
        With oListRng
          .Collapse wdCollapseEnd
          .InsertAfter ","
          .End = .End - 1
          .Paste
          .Start = .End + 1
          .Text = " Page " & iPage & ", Name: " & sFont & sComp & vbCr
          .HighlightColorIndex = wdAuto
        End With
      End With
    Loop
  End With
End With
oListDoc.Range.Paragraphs.Last.Range.Delete
oListDoc.Activate
End Sub






...

Erfahren Sie mehr »- Zitierten Text ausblenden -

- Zitierten Text anzeigen -

Hi Greg,

please see comment to all of you at the very bottom.Terrific support.
Thank you very much. Regards, Andreas

 

[Greg Maxey]

Graham,

Can you make it play a tune ;-)

Using FormattedText did however resolve a problem I was having
getting the macro to format the text correctly in a table cell. I
don't know why I didn't consider it earlier

Using the table does seem noticably faster.

Can you tell it's the slack period twixt Christmas and New Year?

Dim oRng, oNrng As Range
Dim oSource, oDoc As Document
Dim oTable As Table
Dim iRow, iPage, ILen As Integer
Dim iPara, iIst, iLast As Integer
Dim sFont, SComp, sNext, sWords As String
Dim sColor As WdColor
Set oSource = ActiveDocument
Set oDoc = Documents.Add
Set oTable = oDoc.Tables.Add(oDoc.Range, 2, 4)
With oTable
.Cell(1, 1).Range.Text = "Highlighted Text"
.Cell(1, 2).Range.Text = "Page"
.Cell(1, 3).Range.Text = "Font"
.Cell(1, 4).Range.Text = "Comments"
With .Rows(1).Range
.ParagraphFormat.Alignment = _
wdAlignParagraphCenter
.Font.name = "Arial"
.Font.Size = "12"
.Bold = True
End With
End With
oSource.Activate
With Selection
.HomeKey Unit:=wdStory
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Highlight = True
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
Do While .Execute = True
Set oRng = Selection.Range
With oRng
iIst = .Start - .Words.First.Start + 1
iLast = .Words.Last.End - .End
sNext = .Next.Characters(1)
'sColor = .HighlightColorIndex
If .Start <> .Words.First.Start Or _
.End <> .Words.Last.End - 1 And _
sNext <> "" Then
Select Case sNext
Case ",", ".", "?", "!", ":", ";"
SComp = ""
iLast = iLast + 1
Case Else
SComp = "Partly highlighted"
End Select
Else
SComp = ""
End If
.Start = .Words.First.Start
.End = .Words.Last.End
If .Characters.Last = Chr(32) Then
.End = .Words.Last.End - 1
End If
sFont = .Font.name
If Len(sFont) < 1 Then sFont = "Mixed fonts detected"
iPage = .Information(wdActiveEndPageNumber)
iRow = oTable.Rows.Count
oTable.Cell(iRow, 1).Range.FormattedText =
oRng.FormattedText
oTable.Cell(iRow, 2).Range.Text = iPage
oTable.Cell(iRow, 2).Range.ParagraphFormat.Alignment _
= wdAlignParagraphCenter
oTable.Cell(iRow, 3).Range.Text = sFont
oTable.Cell(iRow, 4).Range.Text = SComp
oTable.Rows.Add
End With
Loop
End With
End With
oTable.Rows.Last.Delete
oDoc.Activate