时间戳

首页 > 解决方案 > 将文档从 2 到 7 页拆分为每页一个新文档

vba - 将文档从 2 到 7 页拆分为每页一个新文档

问题描述

我正在尝试用 word 编写代码（宏），我可以在其中将范围定义为页面并将页面从 2 复制到新文档中的 7？

Sub SaveSelected()

 Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=2
    Set rgePages = Selection.Range
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=7
    Documents.Add , wdNewBlankDocument
    Range.Paste
    ActiveDocument.Save
    
End Sub

目前我遇到的问题是代码不起作用。

  1. 将页面定义为范围
  2. 复制范围
  3. 打开一个新的 (.docx)
  4. 另存为窗口（弹出）

标签： vbams-word

解决方案

例如：

将范围内的所有页面保存到新文档

Sub SaveSelected()
   Dim newDoc As Document
   Dim src As Range
   Dim pages As Range
   
   'set src range to start at page 2
   Set src = ActiveDocument.GoTo(what:=wdGoToPage, Which:=wdGoToAbsolute, Count:=2)
   'extend range to the end of page 7
   Set pages = ActiveDocument.GoTo(what:=wdGoToPage, Which:=wdGoToAbsolute, Count:=7)
   src.End = pages.GoTo(what:=wdGoToBookmark, Name:="\page").End
   Set newDoc = Documents.Add(, wdNewBlankDocument)
   newDoc.Content.FormattedText = src.FormattedText
   'remove extra paragraph at end
   With newDoc.Paragraphs.Last.Range
      If Len(.Text) = 1 Then .Delete
   End With
   newDoc.Paragraphs.Last.Range.Delete
   newDoc.Save 
End Sub

将范围内的每一页保存到新文档

Sub SavePages()
   SavePageToNewDocument ActiveDocument, 2, 7
End Sub

Sub SavePageToNewDocument(SourceDoc As Document, FirstPage As Long, LastPage As Long)
   Dim pageNum As Long
   Dim srcPage As Range
   Dim footer As Range
   Dim newDoc As Document
   
   For pageNum = FirstPage To LastPage
      Set srcPage = SourceDoc.GoTo(what:=wdGoToPage, Which:=wdGoToAbsolute, Count:=pageNum)
      srcPage.End = srcPage.GoTo(what:=wdGoToBookmark, Name:="\page").End
      Set footer = srcPage.Sections(1).Footers(wdHeaderFooterPrimary).Range
      Set newDoc = Documents.Add(, wdNewBlankDocument)
      'take across text and formatting
      newDoc.Range.FormattedText = srcPage.FormattedText
      With newDoc.Sections(1).Footers(wdHeaderFooterPrimary).Range
         .FormattedText = footer.FormattedText
         'remove extra paragraph at end
         With .Paragraphs.Last.Range
            If Len(.Text) = 1 Then .Delete
         End With
      End With
      'remove extra paragraph at end
      With newDoc.Paragraphs.Last.Range
         If Len(.Text) = 1 Then .Delete
      End With
   Next pageNum
End Sub

另一种方法是获取新文档作为原件的精确副本，并带有页面布局。

Sub SavePageToNewDocument(SourceDoc As Document, FirstPage As Long, LastPage As Long)
   Dim pageNum As Long
   Dim srcPage As Range
   Dim footer As Range
   Dim newDoc As Document
   
   For pageNum = FirstPage To LastPage
      Set srcPage = SourceDoc.GoTo(what:=wdGoToPage, Which:=wdGoToAbsolute, Count:=pageNum)
      srcPage.End = srcPage.GoTo(what:=wdGoToBookmark, Name:="\page").End
      Set footer = srcPage.Sections(1).Footers(wdHeaderFooterPrimary).Range
      'create new document from the saved version of source document to get page layout
      Set newDoc = Documents.Add(SourceDoc.FullName)
      newDoc.Content.Delete
      'take across text and formatting
      newDoc.Range.FormattedText = srcPage.FormattedText
      'remove extra paragraph at end
      With newDoc.Paragraphs.Last.Range
         If Len(.Text) = 1 Then .Delete
      End With
   Next pageNum
End Sub

推荐阅读