Comment diviser mon document en plusieurs documents avec des sauts de page en VBA ?

Question

Je suis novice en matière de VBA. J'ai obtenu cette macro en ligne et elle a déjà fonctionné pour moi auparavant, mais je reçois maintenant une erreur d'exécution.

La macro est censée prendre un document fusionné par courrier que j'ai, et le diviser en documents individuels pour chaque destinataire.

L'erreur d'exécution 5487 me renvoie à la ligne

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

J'ai essayé de l'enregistrer dans un format de fichier différent, et j'ai parcouru les autres messages sur StackOverflow où d'autres personnes rencontrent la même erreur, mais je reçois toujours le message d'erreur.

Mon code est :

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

Merci !

Answer 1

Sans en savoir plus (comme la valeur de StrTxt ), je ne peux pas dire avec certitude por qué vous obtenez l'erreur mais il s'agit probablement d'un nom de fichier invalide, ou le fichier est verrouillé par un autre processus, ou un problème de permissions.

Peut-être la procédure ci-dessous vous conviendra-t-elle mieux. (Je ne comprends pas bien la signification de "records" dans votre code).

---

Divisez le document en fichiers séparés pour chaque page :

Cette procédure divise le ActiveDocument en un seul .DOCX par "page visible" (sauts de page calculés, sauts de page manuels, sauts de section, etc).

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

Ceci est librement basé sur l'exemple à Partage de logiciels utiles .

Les nouveaux fichiers sont sauvegardés dans le même dossier que ActiveDocument.Path avec le titre du document accompagné d'un numéro séquentiel. Il convient de noter que les fichiers de sortie existants sont écrasés et il n'y a pas de validation ou de traitement des erreurs.