Copy all highlighted words in footnotes into new document

[andreas]

Dear Experts:

I wonder whether a macro could perfrom the following tasks:

Copy all highlighted characters/words in the footnotes into a new
document as follows (example):

Footnote 1, page 17, listing of all highlighted characters/words in
that footnote
Footnote 3, page 24, listing of all highlighted characters/words in
that footnote
etc.

I hope I could make myself clear. Any help would be much appreciated.

Thank you. Regards, Andreas

 

[Helmut Weber]

Hi Andreas,

like that and probably in other ways, too:

Public Sub MyTestx()
Dim rWrd As Range ' a word
Dim Source As Document
Dim Target As Document
Dim sTmp As String
Dim FtnI As Long ' footnote index
Dim FntP As Long ' footnote page
Set Source = ActiveDocument
Dim rFtn As Footnote
Dim rTmp As Range
Set Target = Documents.Add
Source.Activate
For Each rFtn In ActiveDocument.Footnotes
Set rTmp = rFtn.Range
' rTmp.Select
FtnI = rFtn.Index
FntP = rFtn.Range.Information(wdActiveEndPageNumber)
sTmp = "Footnote " & FtnI & ", " & _
"page " & FntP & ": "
For Each rWrd In rFtn.Range.Words
If rWrd.HighlightColorIndex <> 0 Then
sTmp = sTmp & rWrd.Text
End If
Next
With Target.Range
.InsertAfter sTmp & vbCrLf
End With
Next
End Sub

--

Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Vista Small Business, Office XP

 

[andreas]

Hi Andreas,

like that and probably in other ways, too:

Public Sub MyTestx()
Dim rWrd As Range ' a word
Dim Source As Document
Dim Target As Document
Dim sTmp As String
Dim FtnI As Long ' footnote index
Dim FntP As Long ' footnote page
Set Source = ActiveDocument
Dim rFtn As Footnote
Dim rTmp As Range
Set Target = Documents.Add
Source.Activate
For Each rFtn In ActiveDocument.Footnotes
   Set rTmp = rFtn.Range
   ' rTmp.Select
   FtnI = rFtn.Index
   FntP = rFtn.Range.Information(wdActiveEndPageNumber)
   sTmp = "Footnote " & FtnI & ", " & _
      "page " & FntP & ": "
   For Each rWrd In rFtn.Range.Words
      If rWrd.HighlightColorIndex <> 0 Then
         sTmp = sTmp & rWrd.Text
      End If
   Next
   With Target.Range
      .InsertAfter sTmp & vbCrLf
   End With
Next
End Sub

--

Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Vista Small Business, Office XP

Helmut,

as always a professional job from your side. I wonder whether it is
possible to copy and paste the formatted text into the new document?
Help is much appreciated. Thank you very much in advance. Regards,
Andreas

 

[Helmut Weber]

Hi Andreas,

like that:

Public Sub MyTest993()
Dim rWrd As Range ' a word
Dim Source As Document
Dim Target As Document
Dim sTmp As String
Dim FtnI As Long ' footnote index
Dim FntP As Long ' footnote page
Set Source = ActiveDocument
Dim rFtn As Footnote
Dim rTmp As Range
Set Target = Documents.Add
Source.Activate
For Each rFtn In ActiveDocument.Footnotes
Set rTmp = rFtn.Range
rTmp.Select
If rTmp.HighlightColorIndex <> 0 Then
FtnI = rFtn.Index
FntP = rFtn.Range.Information(wdActiveEndPageNumber)
sTmp = "Footnote " & FtnI & ", " & _
"page " & FntP & ": "
With Target.Range
.InsertAfter sTmp
End With
End If
For Each rWrd In rFtn.Range.Words
If rWrd.HighlightColorIndex <> 0 Then
rWrd.Select
rWrd.Copy
' Stop
Target.Range.Select
selection.EndKey Unit:=wdStory
selection.Paste
End If
Next
Target.Range.InsertAfter vbCrLf
Next
End Sub

But this involves a lot of flickering...

I didn't try setting a range.FormattedText of the target doc
to a range.FormattedText of the source doc,
as my experiences with FormattedText are not too good.
--

Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Vista Small Business, Office XP

 

[andreas]

Hi Andreas,

like that:

Public Sub MyTest993()
Dim rWrd As Range ' a word
Dim Source As Document
Dim Target As Document
Dim sTmp As String
Dim FtnI As Long ' footnote index
Dim FntP As Long ' footnote page
Set Source = ActiveDocument
Dim rFtn As Footnote
Dim rTmp As Range
Set Target = Documents.Add
Source.Activate
For Each rFtn In ActiveDocument.Footnotes
   Set rTmp = rFtn.Range
   rTmp.Select
   If rTmp.HighlightColorIndex <> 0 Then
      FtnI = rFtn.Index
      FntP = rFtn.Range.Information(wdActiveEndPageNumber)
      sTmp = "Footnote " & FtnI & ", " & _
      "page " & FntP & ": "
      With Target.Range
         .InsertAfter sTmp
      End With
   End If
   For Each rWrd In rFtn.Range.Words
      If rWrd.HighlightColorIndex <> 0 Then
         rWrd.Select
         rWrd.Copy
'         Stop
         Target.Range.Select
         selection.EndKey Unit:=wdStory
         selection.Paste
      End If
   Next
   Target.Range.InsertAfter vbCrLf
Next
End Sub

But this involves a lot of flickering...

I didn't try setting a range.FormattedText of the target doc
to a range.FormattedText of the source doc,
as my experiences with FormattedText are not too good.
--

Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Vista Small Business, Office XP

Hey Helmut,

whoou, what a great job! You surely deserve your title (Word MVP).
Thank you so much for your terrific help.
Regards, Andreas

 

[Helmut Weber]

Hi Andreas,

before somebody else corrects my mistakes,
here comes an as regarding to speed improved version:

Public Sub MyTest993()
Dim rWrd As Range ' a word
Dim Source As Document
Dim Target As Document
Dim sTmp As String
Dim FtnI As Long ' footnote index
Dim FntP As Long ' footnote page
Dim rFtn As Footnote
Dim rTmp As Range
Set Source = ActiveDocument
Set Target = Documents.Add
Source.Activate
For Each rFtn In ActiveDocument.Footnotes
Set rTmp = rFtn.Range
'rTmp.Select
If rTmp.HighlightColorIndex <> 0 Then
FtnI = rFtn.Index
FntP = rFtn.Range.Information(wdActiveEndPageNumber)
sTmp = "Footnote " & FtnI & ", " & _
"page " & FntP & ": "
With Target.Range
.InsertAfter sTmp
End With
For Each rWrd In rFtn.Range.Words
If rWrd.HighlightColorIndex <> 0 Then
rWrd.Select
rWrd.Copy
Target.Range.Select
selection.EndKey Unit:=wdStory
selection.Paste
End If
Next
End If
Target.Range.InsertAfter vbCrLf
Next
End Sub

--

Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Vista Small Business, Office XP

 

[andreas]

Hi Andreas,

before somebody else corrects my mistakes,
here comes an as regarding to speed improved version:

Public Sub MyTest993()
Dim rWrd As Range ' a word
Dim Source As Document
Dim Target As Document
Dim sTmp As String
Dim FtnI As Long ' footnote index
Dim FntP As Long ' footnote page
Dim rFtn As Footnote
Dim rTmp As Range
Set Source = ActiveDocument
Set Target = Documents.Add
Source.Activate
For Each rFtn In ActiveDocument.Footnotes
   Set rTmp = rFtn.Range
   'rTmp.Select
   If rTmp.HighlightColorIndex <> 0 Then
      FtnI = rFtn.Index
      FntP = rFtn.Range.Information(wdActiveEndPageNumber)
      sTmp = "Footnote " & FtnI & ", " & _
      "page " & FntP & ": "
      With Target.Range
         .InsertAfter sTmp
      End With
      For Each rWrd In rFtn.Range.Words
         If rWrd.HighlightColorIndex <> 0 Then
            rWrd.Select
            rWrd.Copy
            Target.Range.Select
            selection.EndKey Unit:=wdStory
            selection.Paste
         End If
      Next
   End If
   Target.Range.InsertAfter vbCrLf
Next
End Sub

--

Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Vista Small Business, Office XP

Helmut,
thank you very much again. It really is quicker. Again, thank you
very much for your terrific help.