Как разделить один документ на множество разрывов страниц в VBA?

Question

Я новичок в 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

Спасибо!

Answer 1

Не зная больше (например, значение 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, к заголовку документа добавляется порядковый номер.Обратите внимание, что существующие выходные файлы перезаписаны , и нет проверки или обработки ошибок.