时间戳

首页 > 解决方案 > 如何在 VBA 的分页符处将我的一个文档拆分为多个文档？

vba - 如何在 VBA 的分页符处将我的一个文档拆分为多个文档？

问题描述

我是 VBA 新手。我从网上得到了这个宏，它以前对我有用，但现在我从它那里得到一个运行时错误。

该宏应该获取我拥有的邮件合并文档，并将其拆分为每个收件人的单独文档。

运行时错误 5487 将我指向该行

" .SaveAs fileName:=StrTxt &...".

我试图将其保存为不同的文件格式，并浏览了 StackOverflow 上的其他帖子，其他帖子也有相同的错误，但我仍然收到错误消息。

我的代码是：

Sub SplitMergedDocument()
  ' Source: http://msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
  Const StrNoChr As String = """*./\:?|"
  Dim i As Long, j As Long, k As Long, StrTxt As String
  Dim Rng As Range, Doc As Document, HdFt As HeaderFooter
  Application.ScreenUpdating = False
  j = InputBox("How many Section breaks are there per record?", "Split By Sections ", 1)
  With ActiveDocument
      For i = 1 To .Sections.Count - 1 Step j ' Process each Section
          With .Sections(i)
              Set Rng = .Range.Paragraphs(1).Range ' Get 1st paragraph
              With Rng
                  .MoveEnd wdCharacter, -1 'range to exclude final paragraph break
                  StrTxt = .Text
                  For k = 1 To Len(StrNoChr)
                      StrTxt = Replace(StrTxt, Mid(StrNoChr, k, 1), "_")
                  Next
              End With
              ' Construct destination file path & name
              StrTxt = ActiveDocument.Path & Application.PathSeparator & StrTxt
              Set Rng = .Range ' Get whole Section
              With Rng
                  If j > 1 Then .MoveEnd wdSection, j - 1
                  .MoveEnd wdCharacter, -1 'Contract range to exclude Section break
                  .Copy ' Copy range
              End With
          End With
          ' Create output document
          Set Doc = Documents.Add(Template:=ActiveDocument.AttachedTemplate.FullName _
              , Visible:=False)
          With Doc
              ' Paste contents into output document, preserving formatting
              .Range.PasteAndFormat (wdFormatOriginalFormatting)
              ' Delete trailing paragraph breaks & page breaks at end
              While .Characters.Last.Previous = vbCr Or .Characters.Last.Previous = Chr(12)
                  .Characters.Last.Previous = vbNullString
              Wend
              For Each HdFt In Rng.Sections(j).Headers ' Replicate headers & footers
                  .Sections(j).Headers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
              Next
              For Each HdFt In Rng.Sections(j).Footers
                  .Sections(j).Footers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
              Next
              ' Save & close output document
              .SaveAs FileName:=StrTxt & ".docx", FileFormat:=wdFormatXMLDocument _
                    , AddToRecentFiles:=False
              .Close SaveChanges:=False
          End With
      Next
  End With
  Set Rng = Nothing: Set Doc = Nothing
  Application.ScreenUpdating = True
End Sub

谢谢！

标签： vbasplitms-wordpage-break

解决方案

在不了解更多信息（例如 的值StrTxt）的情况下，我无法确定您收到错误的原因，但可能是文件名无效，或者文件被另一个进程锁定，或者权限问题。

也许下面的过程对您更有效。（我不清楚您的代码中“记录”的重要性。）

将文档拆分为每个页面的单独文件：

此过程将每个“可见页面”拆分ActiveDocument为一个.DOCX文件（计算分页符、手动分页符、分节符等）。\

Sub WordDocToPages()
'splits active Word doc by page into separate DOCX files (same folder as active doc)
  Dim doc As Document, docPage As Document, rgPage As Range
  Dim pgNum As Long, pgCnt As Long, ext As String, fName As String
  Set doc = ActiveDocument                                        'Use current document
  Set rgPage = doc.Range                                          'create range of 1 page
  Application.ScreenUpdating = False                              'prevent screen updates
  pgCnt = doc.Content.Information(wdNumberOfPagesInDocument)      'get page count
  Do While pgNum < pgCnt
      pgNum = pgNum + 1                                           'increment page counter
      Application.StatusBar = "Saving page " & pgNum & " of " & pgCnt
      If pgNum < pgCnt Then
          Selection.GoTo wdGoToPage, wdGoToAbsolute, pgNum + 1    'top of next page
          rgPage.End = Selection.Start                            'end of page=top of next
      Else
          rgPage.End = doc.Range.End                              'end of last page=EOF
      End If
      rgPage.Copy                                                 'copy page
      Set docPage = Documents.Add(Visible:=False)                 'create new document
      With docPage
          With .Range
              .Paste 'paste page
              .Find.Execute Findtext:="^m", ReplaceWith:=""       'remove manual breaks
              .Select
          End With
          With Selection
              .EndKey wdStory                                     'goto end of doc
              .MoveLeft wdCharacter, 1, wdExtend                  'remove final CR
              If Asc(.Text) = 13 Then .Delete wdCharacter, 1      'remove trailing CR
          End With
          ext = Mid(doc.FullName, InStrRev(doc.FullName, "."))    'extract file extension
          fName = Replace(doc.FullName, ext, " #" & _
              Format(pgNum, String(Len(CStr(pgCnt)), "0")) & ".docx") 'new filename
          .SaveAs fName, wdFormatDocumentDefault                  'save single-page doc
          .Close                                                  'close new document
      End With
      rgPage.Collapse wdCollapseEnd                               'ready for next page
  Loop

  Application.ScreenUpdating = True                               'resume screen updates
  Application.StatusBar = "Document was split into " & pgNum & " files."
  Set docPage = Nothing: Set rgPage = Nothing: Set doc = Nothing  'cleanup objects
End Sub

这大致基于有用软件共享中的示例。

新文件保存在与 相同ActiveDocument.Path的文件夹中，文档标题附加一个序号。请注意，现有的输出文件会被覆盖，并且没有验证或错误处理。

推荐阅读