Save highlights within the current selected regions into a fixed document

puff · #1 04-12-2017, 08:51 PM

My goal: copy and paste the highlights within the selected regions to another doc file (see the picture below). This means that when I select the region and run my macro, I want only "group together as" to be the result I get.

My current macro:

Sub CopyHighlightsSelectedToOtherDoc()
Dim ThisDoc As Document
Dim ThatDoc As Document
Dim r As Range
Set ThisDoc = ActiveDocument
Set r = ActiveDocument.Range(Selection.Range.Start, Selection.Range.End)
Set ThatDoc = Documents.Add
With r.Find
.Text = ""
.Highlight = True
Do While .Execute(Forward:=True) = True
ThatDoc.Range.InsertAfter r.Text & vbCrLf
r.Collapse 0
Loop
End With
End Sub

Problem: I'm a newbie and just found the original code somewhere else and modified it a bit. But there will always be an error on the Range Selection part. In this case, is that possible to let the macro use the currently selected sections only not the whole document? Some posts said macro cannot do things like that. My current code always goes to the end of the document, which gives "group together as" and also "accomplish a task automatically".

Additionally, how to make the macro to save the results in another fixed document? Let's say I want to save it in a file named "container.docx" on the desktop. I tried Set ThatDoc = C:\Users\apple\Desktop\container.docx, but that didn't work. How to solve this then?

I really appreciate anyone who can provide some help.

gmayor · #2 04-12-2017, 11:29 PM

The following should work (at least on the PC version of Word), provided the folder you mentioned exists:

Code:

Option Explicit

Sub CopyHighlightsSelectedToOtherDoc()
Dim ThisDoc As Document
Dim ThatDoc As Document
Dim r As Range, orng As Range
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Const strDoc As String = "C:\Users\apple\Desktop\container.docx"    'folder must exist
    Set ThisDoc = ActiveDocument
    Set r = Selection.Range
    Set orng = Selection.Range
    If Len(r) > 0 Then
        If fso.FileExists(strDoc) Then
            Set ThatDoc = Documents.Open(strDoc)
        Else
            On Error GoTo err_Handler
            Set ThatDoc = Documents.Add
            ThatDoc.SaveAs2 strDoc
        End If
        With r.Find
            .Highlight = True
            Do While .Execute(Forward:=True) = True And r.InRange(orng)
                ThatDoc.Range.InsertAfter r.Text & vbCrLf
                r.Collapse 0
            Loop
        End With
        ThatDoc.Save
    Else
        MsgBox "Nothing selected"
    End If
lbl_Exit:
    Set r = Nothing
    Set orng = Nothing
    Exit Sub
err_Handler:
    ThatDoc.Close 0
    MsgBox "Target document not available"
    Err.Clear
    GoTo lbl_Exit
End Sub

macropod · #3 04-13-2017, 03:41 AM

Cross-posted at: http://www.tek-tips.com/viewthread.cfm?qid=1776432
For cross-posting etiquette, please read: http://www.excelguru.ca/content.php?184

puff · #4 04-19-2017, 10:34 AM

Thank you so much! It really works and saves me lots of time

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Chart with Actuals and Goals for Multiple INTL Regions	Italiano329	Excel	4	01-22-2016 09:48 AM
VBA to move selected emails or conversation to current year pst folder	webharvest	Outlook	1	08-15-2015 01:55 AM
Fixed duration, fixed units, fixed work, effort driven. How, why and when use it all	Evgeny	Project	3	01-03-2013 06:45 AM
How to use fixed duration, fixed work and have resources/units leveled automatically?	Joeb	Project	3	06-25-2012 04:18 PM
Save Current Slide as Picture	excelledsoftware	PowerPoint	2	01-18-2012 02:42 PM