Vba word copy documents - Word и Excel - помощь в работе с программами

I haven’t used VB for years, so please forgive me if this turns out to be obvious. I’m trying to write a word vba macro for use in a template which will display a userform and then import the contents of fileA.docx, fileB.docx, or fileC.docx depending on the userform. (After that I’m going to use bookmarks to fill in some form data, I don’t know if that’s relevant). Files A, B, and C will contain text with some basic formatting such as lists, but nothing fancy.

The solutions I’ve seen online can copy the contents of file to a new file, but ideally I would like to import the entirety of one of those files into the new, currently unnamed file that I’m getting from the template. I think where I’m running into problems is with switching the selection to one of those files, and then back to the new unnamed document, though I could use a hand to make sure I’m copying correctly as well.

Update: I was making things too hard, though the answers here got me pointed in the right direction (thanks!). In the end I just did

ThisDocument.Activate

Selection.InsertFile("fileA")

which gives me the raw dump of everything that I wanted.

Источник

Remove From My Forums

Question
Dear All,

Merry Xmas to Everyone on the Forum.

I have a question regarding Word VBA. I have multiple word files that I would like to merge their content into one file. I wonder how this can be done in Word VBA. I wrote a sample code that open and merge two files, one after another. But the content
won’t merge properly. When I run the code I only get the content of the second file. Where am I wrong? Thank you for your help Below is the code.

Sub testpro()

    Dim originalApp As Word.Application, tempApp As Word.Application, newApp As Word.Application
    Dim originalDoc As Word.Document, tempDoc As Word.Document, newDoc As Word.Document
    Dim myPath As String, myPath1 As String, myPath2 As String, myPath3 As String


    myPath = ThisDocument.Path
    myPath1 = myPath & «1.docx»
    myPath2 = myPath & «2.docx»
    myPath3 = myPath & «test.docx»


    Set newApp = CreateObject(«Word.Application»)
    Set newDoc = newApp.Documents.Add()
    newApp.Visible = True
    On Error Resume Next


    Set originalApp = GetObject(, «Word.Application»)
    Set originalDoc = originalApp.Documents.Open(myPath1)
    On Error Resume Next


    Set tempApp = GetObject(, «Word.Application»)
    Set tempDoc = tempApp.Documents.Open(myPath2)
    On Error Resume Next


    originalDoc.Activate
    Selection.WholeStory
    Selection.Copy
    newDoc.Activate
    Selection.PasteAndFormat (wdPasteDefault)


    tempDoc.Activate
    Selection.WholeStory
    Selection.Copy


    newDoc.Activate
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=»2″
    Selection.Find.ClearFormatting
        With Selection.Find
            .Text = «»
            .Replacement.Text = «»
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchByte = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
    Selection.PasteAndFormat (wdPasteDefault)


    ActiveDocument.SaveAs (myPath3)


    originalDoc.Close
    tempDoc.Close
    newDoc.Close


    Set originalDoc = Nothing
    Set tempDoc = Nothing
    Set newDoc = Nothing

End Sub

Answers

Where do you want to run this code? If you want to run it from within Word (which seems likely, since you refer to ThisDocument), there is no need to use CreateObject and GetObject at all. If you want to run it from another application, there is no need
to create three variables of type Word.Application — one is enough.

Try this version (to be run in Word):
```
Sub testpro()
    Dim originalDoc As Document, tempDoc As Document, newDoc As Document
    Dim myPath As String, myPath1 As String, myPath2 As String, myPath3 As String
    Dim rng As Range

    myPath = ThisDocument.Path
    myPath1 = myPath & "1.docx"
    myPath2 = myPath & "2.docx"
    myPath3 = myPath & "test.docx"

    Set newDoc = Documents.Add
    Set originalDoc = Documents.Open(myPath1)
    Set tempDoc = Documents.Open(myPath2)

    originalDoc.Content.Copy
    Set rng = newDoc.Content
    rng.Collapse Direction:=wdCollapseEnd
    rng.Paste

    tempDoc.Content.Copy
    Set rng = newDoc.Content
    rng.Collapse Direction:=wdCollapseEnd
    rng.Paste

    newDoc.SaveAs myPath3

    originalDoc.Close SaveChanges:=False
    tempDoc.Close SaveChanges:=False
    newDoc.Close SaveChanges:=False
End Sub
```
Regards, Hans Vogelaar
- Edited by
  
  Thursday, December 27, 2012 11:51 AM
- Marked as answer by
  forestrock
  Thursday, December 27, 2012 12:20 PM

Источник

This tutorial explains how you can copy content from one word document and paste it to another word document with VBA. This is one of the most common ask from stakeholder when you need to create a new MS word document daily or weekly which is a subset of the master document. If you do it manually, it’s a tedious task and chances of having error would be high. In the automated world we aim to automate our repetitive tasks as much as possible. As a request it looks easy but it’s a bit complex as you need to handle MS word from Excel and need to give instructions to system via VBA about the changes and interactivity you want to implement.

Table of Contents

Copy all headings to another document

The program below copies each text which is formatted in Heading 1 style and paste to a new word document. You need to make changes in the lines of code highlighted in red.

Sub CopyfromWord()
    
   ' Objects
    Dim wrdApp, objWord As Object
    Dim wrdDoc, newwrdDoc As Object
    Dim myPath As String, myPath1 As String
    Dim numberStart As Long
    Dim Rng, srchRng As Word.Range

   ' Close MS Word if it's already opened
    On Error Resume Next
     Set objWord = GetObject(, "Word.Application")
     If Not objWord Is Nothing Then
            objWord.Quit SaveChanges:=0
            Set objWord = Nothing
    End If
    
    'Open MS Word
    Set wrdApp = CreateObject("Word.Application")
        wrdApp.Visible = True
        
    ' Folder Location
    myPath = "C:UsersDELLDocumentsTest" 
    
    ' Input File
    Set wrdDoc = wrdApp.Documents.Open(myPath & "PD Calibration.docx")
    
    ' Output File
    Set newwrdDoc = wrdApp.Documents.Add
    myPath1 = myPath & "newdoc1.docx"

    ' Text you want to search
    Dim FindWord As String
    Dim result As String
    FindWord = ""
    
    'Style
    mystyle = "Heading 1"
    
    'Defines selection for Word's find function
    wrdDoc.SelectAllEditableRanges
    
    ' Find Functionality in MS Word
    With wrdDoc.ActiveWindow.Selection.Find
        .Text = FindWord
        .Replacement.Text = ""
        .Forward = True
        .Wrap = 1
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        If mystyle <> "" Then
        .Style = mystyle
        End If
    End With
    
    ' Execute find method
    wrdDoc.ActiveWindow.Selection.Find.Execute
    
    ' Store Selected text
    result = wrdDoc.ActiveWindow.Selection.Text
    
    ' Check if result contains non-blank text
    If Len(result) > 1 Then
    
    ' -------------------------------------------------------------
    ' Loop through multiple find content (Find All functionality)
    ' -------------------------------------------------------------

    While wrdDoc.ActiveWindow.Selection.Find.Found
    wrdDoc.ActiveWindow.Selection.Copy
    
    'Activate the new document
    newwrdDoc.Activate
    
    'New Word Doc
    Set Rng = newwrdDoc.Content
    Rng.Collapse Direction:=wdCollapseEnd
    Rng.Paste
   
   'Word Document
   wrdDoc.Activate
   wrdDoc.ActiveWindow.Selection.Find.Execute
   
   Wend
   
   ' If style not found
    Else
        MsgBox "Text Not Found"
    End If
   
    'Close and don't save application
    wrdDoc.Close SaveChanges:=False
    
    'Save As New Word Document
    newwrdDoc.SaveAs myPath1
    newwrdDoc.Close SaveChanges:=False
    
    'Close all word documents
    wrdApp.Quit SaveChanges:=0
    
    'Message when done
    MsgBox "Task Accomplished"
End Sub

How to use the above program

Open Excel Workbook
Press ALT + F11 shortcut key to open visual basic editor (VBE)
To insert a module, go to Insert > Module
Paste the complete VBA script below
Specify the path of folder in myPath variable. It is the folder location where your input word document file is stored. Make sure to mention backward slash at the end.
myPath = "C:UsersDELLDocumentsTest"
Specify file name of your input MS Word document
Set wrdDoc = wrdApp.Documents.Open(myPath & "PD Calibration.docx")
File name you wish to have in your output file. New word doc will be saved with this name.
myPath1 = myPath & "newdoc1.docx"
Type word(s) you want to seach in Find box. Keep it blank if you want to search by style only. FindWord = "".
Specify style specific to your word document in mystyle = "Heading 1".

How this program works

In this section we broken down the code into multiple snippets to make you understand how it works.

1. First we are closing word documents if any of them is already opened. It is to avoid conflict interacting Excel with Word. This is a useful technique in terms of error handling in the code as sometimes code may crash because of multiple word documents being opened at the same time.

    On Error Resume Next
     Set objWord = GetObject(, "Word.Application")
     If Not objWord Is Nothing Then
            objWord.Quit SaveChanges:=0
            Set objWord = Nothing
    End If

2. In this section of code we are opening the input word document.

    'Open MS Word
    Set wrdApp = CreateObject("Word.Application")
        wrdApp.Visible = True
        
    ' Folder Location
    myPath = "C:UsersDELLDocumentsTest"
    
    ' Input File
    Set wrdDoc = wrdApp.Documents.Open(myPath & "PD Calibration.docx")

3. Here we are adding a new word document in which we want to copy the content.

    Set newwrdDoc = wrdApp.Documents.Add
    myPath1 = myPath & "newdoc1.docx"

4. User need to mention the word or style he/she wants MS Word to look for.

    ' Text you want to search
    Dim FindWord As String
    Dim result As String
    FindWord = ""
    
    'Style
    mystyle = "Heading 1"

5. This part of the VBA code refers to Find feature in MS Word. Many of us enable this functionality by hitting CTRL + F shortcut key. While ... Wend is an alternative of Do While Loop. Here it is used to find all the words which are formatted as ‘Heading 1’ style. It is to find all the searched results in iterative manner. After copying the text it goes to the last filled content in the output doc and then paste the content after that.

    With wrdDoc.ActiveWindow.Selection.Find
        .Text = FindWord
        .Replacement.Text = ""
        .Forward = True
        .Wrap = 1
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        If mystyle <> "" Then
        .Style = mystyle
        End If
    End With
    
    ' Execute find method selects the found text if found
    wrdDoc.ActiveWindow.Selection.Find.Execute
    
    While wrdDoc.ActiveWindow.Selection.Find.Found
    wrdDoc.ActiveWindow.Selection.Copy
    
    'Activate the new document
    newwrdDoc.Activate
    
    'New Word Doc
    Set Rng = newwrdDoc.Content
    Rng.Collapse Direction:=wdCollapseEnd
    Rng.Paste
   
   'Word Document
   wrdDoc.Activate
   wrdDoc.ActiveWindow.Selection.Find.Execute
   
   Wend

6. Last thing which is extremely important is to save the files and close MS Word application. We are closing the input file without saving any changes but the output file is saved with all the changes we made.

    'Close and don't save application
    wrdDoc.Close SaveChanges:=False
    
    'Save As New Word Document
    newwrdDoc.SaveAs myPath1
    newwrdDoc.Close SaveChanges:=False
    
    'Close all word documents
    wrdApp.Quit SaveChanges:=0

Copy text from one word document to already created word document

Suppose you don’t want to create a new word document. Instead you wish to save it in the existing word doc you have. Assuming name of the output file is newdoc1.docx.

Replace this line of code Set newwrdDoc = wrdApp.Documents.Add with the code below.

    Set newwrdDoc = wrdApp.Documents.Open(myPath & "newdoc1.docx")

If you wish to save the file with the new name you can change in this line of code.

myPath1 = myPath & "newdoc1_updated.docx"

Find specific text and then copy the next 3 words or characters

Specify the word(s) you want to find in FindWord = "Text you wish to search" and make style blank in
mystyle = ""

Replace this line of code wrdDoc.ActiveWindow.Selection.Copy with the code below.

Next 3 words

    lngStart = wrdDoc.ActiveWindow.Selection.End
    wrdDoc.ActiveWindow.Selection.MoveRight Unit:=wdWord, Count:=3, Extend:=wdExtend
    wrdDoc.ActiveWindow.Selection.Collapse Direction:=wdCollapseEnd
    lngEnd = wrdDoc.ActiveWindow.Selection.Start
    wrdDoc.Range(lngStart, lngEnd).Copy
    wrdDoc.ActiveWindow.Selection.EndOf

Next 3 Characters

   lngStart = wrdDoc.ActiveWindow.Selection.End
    wrdDoc.Range(lngStart, lngStart + 3).Copy

If there are some spaces you may find the code extracts only 2 characters (or words) rather than 3 so you can increase the number from 3 to 4 in the code above

Copy text between two words

Suppose you wish to pull all the text between two words (or headings). In the code below you can specify the words in FindWord1 and FindWord2 variables.

Sub CopyBetweenTexts()
    
   ' Objects
    Dim wrdApp, objWord As Object
    Dim wrdDoc, newwrdDoc As Object
    Dim myPath As String, myPath1 As String
    Dim numberStart As Long
    Dim Rng, srchRng As Word.Range

   ' Close MS Word if it's already opened
    On Error Resume Next
     Set objWord = GetObject(, "Word.Application")
     If Not objWord Is Nothing Then
            objWord.Quit SaveChanges:=0
            Set objWord = Nothing
    End If
    
    'Open MS Word
    Set wrdApp = CreateObject("Word.Application")
        wrdApp.Visible = True
        
    ' Folder Location
    myPath = "C:UsersDELLDocumentsTest"
    
    ' Input File
    Set wrdDoc = wrdApp.Documents.Open(myPath & "PD Calibration.docx")
    
    ' Output File
    Set newwrdDoc = wrdApp.Documents.Add
    myPath1 = myPath & "newdoc1.docx"

    ' Text you want to search
    Dim FindWord1, FindWord2 As String
    Dim result As String
    FindWord1 = "Steps : PD Calibration"
    FindWord2 = "Test2 Steps : PD Calibration"
    
    'Style
    mystyle = ""

    'Defines selection for Word's find function
    wrdDoc.SelectAllEditableRanges
    
     ' Move your cursor to the start of the document
    wrdDoc.ActiveWindow.Selection.HomeKey unit:=wdStory

    'Find Functionality in MS Word
    With wrdDoc.ActiveWindow.Selection.Find
        .Text = FindWord1
        .Replacement.Text = ""
        .Forward = True
        .Wrap = 1
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        If mystyle <> "" Then
        .Style = mystyle
        End If
             If .Execute = False Then
            MsgBox "'Text' not found.", vbExclamation
            Exit Sub
        End If
        
        ' Locate after the ending paragraph mark (beginning of the next paragraph)
        ' wrdDoc.ActiveWindow.Selection.Collapse Direction:=wdCollapseEnd
        
        ' Starting character position of a selection
        lngStart = wrdDoc.ActiveWindow.Selection.End 'Set Selection.Start to include searched word
        .Text = FindWord2
        .Replacement.Text = ""
        .Forward = True
        .Wrap = 1
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Style = mystyle
        If .Execute = False Then
            MsgBox "'Text2' not found.", vbExclamation
            Exit Sub
        End If
        lngEnd = wrdDoc.ActiveWindow.Selection.Start 'Set Selection.End to include searched word
    End With
    
  'Copy Selection
  wrdDoc.Range(lngStart, lngEnd).Copy
    
    'Activate the new document
    newwrdDoc.Activate
    
    'New Word Doc
    Set Rng = newwrdDoc.Content
    Rng.Collapse Direction:=wdCollapseEnd
    Rng.Paste
   
   'Word Document
   wrdDoc.Activate
   wrdDoc.ActiveWindow.Selection.Find.Execute
   
    'Close and don't save application
    wrdDoc.Close SaveChanges:=False
    
    'Save As New Word Document
    newwrdDoc.SaveAs myPath1
    newwrdDoc.Close SaveChanges:=False
    
    'Close all word documents
    wrdApp.Quit SaveChanges:=0
    
    'Message when done
    MsgBox "Task Accomplished"
    
End Sub

Find multiple different texts and copy in loop

If you wish to extract content between a couple of texts in iterative manner and then copy them one by one in another word document.
Here we assume texts are stored in column B starting from cell B3. See the image below.

Sub CopyBetweenTexts2()
    
   ' Objects
    Dim wrdApp, objWord As Object
    Dim wrdDoc, newwrdDoc As Object
    Dim myPath As String, myPath1 As String
    Dim numberStart As Long
    Dim Rng, srchRng As Word.Range

   ' Close MS Word if it's already opened
    On Error Resume Next
     Set objWord = GetObject(, "Word.Application")
     If Not objWord Is Nothing Then
            objWord.Quit SaveChanges:=0
            Set objWord = Nothing
    End If
    
    'Open MS Word
    Set wrdApp = CreateObject("Word.Application")
        wrdApp.Visible = True
        
    ' Folder Location
    myPath = "C:UsersDELLDocumentsTest"
    
    ' Input File
    Set wrdDoc = wrdApp.Documents.Open(myPath & "PD Calibration.docx")
    
    ' Output File
    Set newwrdDoc = wrdApp.Documents.Add
    myPath1 = myPath & "newdoc1.docx"

    ' Text you want to search
    Dim FindWord1, FindWord2 As String
    Dim result As String
    
    ' Find last used cell in column B
    Dim last As Double
    With ActiveSheet
        last = .Cells(.Rows.Count, "B").End(xlUp).Row
    End With

    ' Loop through column B
    j = last - 2
    For i = 1 To j
    
    FindWord1 = Cells(2 + i, 2).Value
    FindWord2 = Cells(3 + i, 2).Value
    
    'Style
    mystyle = ""

    'Defines selection for Word's find function
    wrdDoc.SelectAllEditableRanges
    
     ' Move your cursor to the start of the document
    wrdDoc.ActiveWindow.Selection.HomeKey unit:=wdStory

    'Find Functionality in MS Word
    With wrdDoc.ActiveWindow.Selection.Find
        .Text = FindWord1
        .Replacement.Text = ""
        .Forward = True
        .Wrap = 1
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        If mystyle <> "" Then
        .Style = mystyle
        End If
             If .Execute = False Then
            MsgBox "'Text' not found.", vbExclamation
            Exit Sub
        End If
        
        ' Locate after the ending paragraph mark (beginning of the next paragraph)
        ' wrdDoc.ActiveWindow.Selection.Collapse Direction:=wdCollapseEnd
        
        ' Starting character position of a selection
        lngStart = wrdDoc.ActiveWindow.Selection.End 'Set Selection.Start to include searched word
        .Text = FindWord2
        .Replacement.Text = ""
        .Forward = True
        .Wrap = 1
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Style = mystyle
        If .Execute = False Then
            MsgBox "'Text2' not found.", vbExclamation
            Exit Sub
        End If
        lngEnd = wrdDoc.ActiveWindow.Selection.Start 'Set Selection.End to include searched word
    End With
    
  If (i = j) Then
  wrdDoc.ActiveWindow.Selection.EndOf
  wrdDoc.ActiveWindow.Selection.EndKey unit:=wdStory
  lngEnd = wrdDoc.ActiveWindow.Selection.End
  End If
    
  'Copy Selection
  wrdDoc.Range(lngStart, lngEnd).Copy
    
    'Activate the new document
    newwrdDoc.Activate
    
    'New Word Doc
    Set Rng = newwrdDoc.Content
    Rng.Collapse Direction:=wdCollapseEnd
    Rng.Paste
    Next i
    
   'Word Document
   wrdDoc.Activate
   wrdDoc.ActiveWindow.Selection.Find.Execute
   
    'Close and don't save application
    wrdDoc.Close SaveChanges:=False
    
    'Save As New Word Document
    newwrdDoc.SaveAs myPath1
    newwrdDoc.Close SaveChanges:=False
    
    'Close all word documents
    wrdApp.Quit SaveChanges:=0
    
    'Message when done
    MsgBox "Task Accomplished"
    
End Sub

Find Text and Replace All

Suppose you want to find a specific text and replace it with some text. If a text has more than 1 occurence, it should be dealt with. In other words, Replace All functionality should be enabled. Here we are replacing it in the output document after copying from input word document. Add the code below after line Next i . Specify text in .Text = and .Replacement.Text =

   'Replace All Name
    newwrdDoc.Activate
    With newwrdDoc.ActiveWindow.Selection.Find
        .Text = "Text 1"
        .Replacement.Text = "Text 2"
        .Forward = True
        .Wrap = 1
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    newwrdDoc.ActiveWindow.Selection.Find.Execute Replace:=wdReplaceAll

About Author:

Deepanshu founded ListenData with a simple objective — Make analytics easy to understand and follow. He has over 10 years of experience in data science. During his tenure, he has worked with global clients in various domains like Banking, Insurance, Private Equity, Telecom and Human Resource.

Источник

Copy

Is a method exposed by various objects like Selection, Range, Document which copies selection in clipboard memory. Let’s write code to copy/paste entire document contents to another document.

Code Example

Sub CopyPasteContent()
    'bind document reference
    Dim cDocument As Document
    Set cDocument = ActiveDocument
    
    'Select contents
    cDocument.Content.Select
    
    'bind selection
    Dim oSelection As Selection
    Set oSelection = Selection
    
    Dim tDocument As Document
    'Check selection type
    If oSelection.Type = wdSelectionNormal Then
        'Copy content
        oSelection.Copy
        'Paste contents in new document and hold the reference
        Set tDocument = Documents.Add
        tDocument.Content.Paste
        'Activate the target document
        tDocument.Activate
    End If
    tDocument.SaveAs2 "d:mytest.docx"
    
    'Memory cleanup
    Set tDocument = Nothing
    Set oSelection = Nothing
End Sub

Please leave your comments or queries under comment section also please do subscribe to out blogs to keep your self upto date.

Источник

Hi, I believe Cindy Meister MVP published this in the German Programming Book which I bought years ago and the update.

Read it carefully and you should be able to choose what formatting you wish to copy.

Select the part of the document you wish to copy first. Then run the macro.

It seems to be what you are after.

Option Explicit
Sub Save_Selection_To_New_File()
‘(Cindy Meister — German Programming Handbook)

‘Variable declaration
Dim rngSel As Word.Range
Dim origSetup As Word.PageSetup
Dim docNew As Word.Document
Dim oDoc As Document
Dim Title As String
Dim Msg As String
Dim Response As VbMsgBoxResult
Title = «Save Selection to New File with Page Layout Format»
Set oDoc = ActiveDocument

‘Stop if no text selected
If oDoc.Bookmarks(«Sel»).Range.text = «» Then
Msg = «Before running the command, you must select the text you want to » & _
«copy for insertion in a New File.»
MsgBox Msg, vbOKOnly, Title
GoTo ExitHere
End If

Msg = «Use this command if you need to copy part of a document to a New File » & _
«and retain page layout and format.» & vbCr & vbCr & _
«When the command is finished save the document.»

Response = MsgBox(Msg, vbOKCancel, Title)

‘Stop if the user does not click OK
If Response <> vbOK Then GoTo ExitHere

‘Assign the selection to its variable
Set rngSel = Selection.Range
Set origSetup = rngSel.Sections(1).PageSetup
‘Create a new document from the current document
‘So that styles, etc. are all present
Set docNew = Documents.Add(ActiveDocument.FullName)
‘Delete everything
docNew.Range.Delete
‘Put the selection into the new document
docNew.Range.FormattedText = rngSel.FormattedText

‘Set the page properties to correspond
‘to the settings for the section in which
‘the selection was made

‘»With» allows multiple properties of an object to be set
‘by treating the words on the With line as a prefix for the
‘lines that start with a .(period) that follow. The With
‘must be ended.
With docNew.Sections(1).PageSetup
.BottomMargin = origSetup.BottomMargin
.TopMargin = origSetup.TopMargin
.LeftMargin = origSetup.LeftMargin
.RightMargin = origSetup.RightMargin
.Gutter = origSetup.Gutter
‘Comment out the next two lines for Wor97
‘and Word 2000
.GutterPos = origSetup.GutterPos
.GutterStyle = origSetup.GutterStyle
.DifferentFirstPageHeaderFooter = _
origSetup.DifferentFirstPageHeaderFooter
.OddAndEvenPagesHeaderFooter = _
origSetup.OddAndEvenPagesHeaderFooter
.FooterDistance = origSetup.FooterDistance
.HeaderDistance = origSetup.HeaderDistance
.MirrorMargins = origSetup.MirrorMargins
.Orientation = origSetup.Orientation
.PaperSize = origSetup.PaperSize
.PageHeight = origSetup.PageHeight
.PageWidth = origSetup.PageWidth
‘»With» allows multiple properties of an object to be set
‘by treating the words on the With line as a prefix for the
‘lines that start with a .(period) that follow. The With
‘must be ended. With statements may be nested.
With .TextColumns
.SetCount NumColumns:=origSetup.TextColumns.Count
.EvenlySpaced = origSetup.TextColumns.EvenlySpaced
.LineBetween = origSetup.TextColumns.LineBetween
If .Count > 1 And .EvenlySpaced Then
‘Variable declaration
Dim i As Long
.Spacing = origSetup.TextColumns.Spacing
If .Spacing = False Then
For i = 1 To .Count
.Item(i).SpaceAfter = _
origSetup.TextColumns(i).SpaceAfter
.Item(i).Width = _
origSetup.TextColumns(i).Width
Next
End If
ElseIf .Count > 1 And Not .EvenlySpaced Then
For i = 1 To .Count
.Width = origSetup.TextColumns(i).Width
Next
End If
End With
End With

‘Define headers, footers and page numbers
Dim pgNr As Long
‘Get the starting page number
rngSel.Collapse wdCollapseStart
pgNr = rngSel.Information(wdActiveEndAdjustedPageNumber)
‘Disables different first page if selection is not on a first page
‘Comment out the following first, and fourth through seventh
‘ lines to see first page headers/footers
‘ in result document if present in original even if
‘ selection is not originally on a first page
If pgNr = 1 Then
ProcessHeadersFooters wdHeaderFooterFirstPage, _
rngSel.Sections(1), docNew.Sections(1)
Else
docNew.Sections(1).PageSetup. _
DifferentFirstPageHeaderFooter = False
End If
‘To NOT retain the original page number,
‘comment out the next four lines

With docNew.Sections(1).Headers(wdHeaderFooterPrimary)
.PageNumbers.RestartNumberingAtSection = True
.PageNumbers.StartingNumber = pgNr
End With

ProcessHeadersFooters wdHeaderFooterPrimary, _
rngSel.Sections(1), docNew.Sections(1)
ProcessHeadersFooters wdHeaderFooterEvenPages, _
rngSel.Sections(1), docNew.Sections(1)

‘Display the FileSaveAs dialog box — NOT IN USE***
‘Dialogs(wdDialogFileSaveAs).Show

Msg = «Finished. Read the Status Line (bottom left corner). You may now save the new file.»
MsgBox Msg, vbOKOnly, Title

ExitHere:
‘Clean up
Set oDoc = Nothing
End Sub

‘Carry over formatted text for the selected section
‘from original document and update the fields

Sub ProcessHeadersFooters(typ As Long, _
sec1 As Word.Section, sec2 As Word.Section)

sec2.Headers(typ).Range.FormattedText = _
sec1.Headers(typ).Range.FormattedText
sec2.Headers(typ).Range.Fields.Update
sec2.Footers(typ).Range.FormattedText = _
sec1.Footers(typ).Range.FormattedText
sec2.Footers(typ).Range.Fields.Update
End Sub

Источник

Question

Answers

Copy all headings to another document

Find specific text and then copy the next 3 words or characters

Copy text between two words

Find multiple different texts and copy in loop

Find Text and Replace All

Copy

Code Example