Macro pour le découpage un-à-plusieurs de documents Word

Question

J'ai un document Word de plusieurs centaines de pages.

Je voudrais utiliser une macro pour créer automatiquement environ une douzaine de sous-documents basés sur certaines règles (principalement, l'occurrence de certaines chaînes dans chaque section).

Est-ce possible? Quelles fonctions VBA dois-je lire? Est-ce que quelqu'un connaît des exemples de code qui sont même à distance et que je peux personnaliser pour mes besoins?

Merci

Answer 1

Il m'a fallu un certain temps pour comprendre comment faire, même avec l'article KB. Tout d'abord, vous devez mettre la macro dans Normal.dotm ... Ouvrez C: \ Users \ Yourname \ AppData \ Roaming \ Microsoft \ Templates \ Normal.dotm dans Word, appuyez sur Alt-F11 et collez le suivant dans le module 1:

Sub BreakOnSection() 
    Application.ScreenUpdating = False 'Makes the code run faster and reduces screen flicker a bit. 

    ' Used to set criteria for moving through the document by section. 
    Application.Browser.Target = wdBrowseSection 
    strBaseFilename = ActiveDocument.Name 
    On Error GoTo CopyFailed 

    'A mail merge document ends with a section break next page. 
    'Note: Document may or may not end with a section break, 
    For I = 1 To ActiveDocument.Sections.Count 

     'Select and copy the section text to the clipboard. 
     ActiveDocument.Bookmarks("\Section").Range.Copy 

     'Create a new document to paste text from clipboard. 
     Documents.Add 
     Selection.Paste 
     DocNum = DocNum + 1 
     strNewFileName = Replace(strBaseFilename, ".do", "_" & Format(DocNum, "000") & ".do") 
    ActiveDocument.SaveAs "C:\Destination\" & strNewFileName 
    ActiveDocument.Close 
     ' Move the selection to the next section in the document. 
    Application.Browser.Next 
    Next I 
    Application.Quit SaveChanges:=wdSaveChanges 
    End 

CopyFailed: 
    'MsgBox ("No final Section Break in " & strBaseFilename) 
    Application.Quit SaveChanges:=wdSaveChanges 
    End 
End Sub 

Enregistrez le fichier Normal.dotm.

L'exécution de ce code divisera un document composé de plusieurs sections en plusieurs documents dans le répertoire C: \ Destination, puis fermera Word.

Vous pouvez exécuter ce billet depuis la ligne de commande via:

"c:\Program Files\Microsoft Office\Office12\WINWORD.EXE" /mBreakOnSection "C:\Path to Source\Document with multiple sections.doc" 

Pour traiter tous les fichiers .doc dans un répertoire, créez un fichier batch comme suit, et l'exécuter:

@ECHO off 
set "dir1=C:\Path to Source" 
echo running 
FOR %%X in ("%dir1%\*.doc") DO "c:\Program Files\Microsoft Office\Office12\WINWORD.EXE" /mBreakOnSection "%%~X" 
echo Done 
pause 

Answer 2

Sub SplitFromSectionBreak() 
'use this to split document from section break 


    Dim i 
    Selection.HomeKey Unit:=wdStory 
    Application.ScreenUpdating = False 
'------ count how much section in document--------- 
    MsgBox (ActiveDocument.Sections.count - 1 & " Sections Found In This Document") 
'-------set path where file to save---------------- 
    Dim path As String 
    path = InputBox("Enter The Destination Folder You Want To Save Files. ", "Path", "C:\Users\Ashish Saini\Desktop\Section Files\") 

    For i = 1 To ActiveDocument.Sections.count - 1 
    With Selection.Find 
    .Text = "^b" 
    .Forward = False 
    .Execute 
    .Text = "" 
    End With 

    Selection.Extend 

    With Selection.Find 
    .Text = "^b" 
    .Forward = True 
    .Wrap = wdFindStop 
    .Execute 
    .Text = "" 

    End With 
     Selection.Copy 
     Documents.Add 
     Selection.Paste 
     Call Del_All_SB 
'----------------------------------------------------------------------- 
     If Dir(path) = "" Then MkDir path 'If path doesn't exist create one 

     ChangeFileOpenDirectory path 

     DocNum = DocNum + 1 
     ActiveDocument.SaveAs filename:="Section_" & DocNum & ".doc" 
     ActiveDocument.Close 

    Next i 
    path = "c:\" 
    ChangeFileOpenDirectory path 
End Sub 

Sub Del_All_SB() 

' this macro also associated with Delete_SectionBreaks() 
'TO DELETE ALL SECTIONS IN DOCUMENT 

Selection.HomeKey Unit:=wdStory 
Selection.Find.ClearFormatting 
Selection.Find.Replacement.ClearFormatting 

With Selection.Find 
    .Text = "^12" 
    .Replacement.Text = "" 
    .Forward = True 
    .Wrap = wdFindContinue 
    .Format = True 
    .MatchCase = False 
    .MatchWholeWord = False 
    .MatchWildcards = False 
    .MatchSoundsLike = False 
    .MatchAllWordForms = False 
End With 
Selection.Find.Execute Replace:=wdReplaceAll 

End Sub 

Answer 3

document word Fractionner par page counter par exemple utiliser 50 à étapes

Sub Spliter(PartStep) 
    If IsEmpty(PartStep) Or Not IsNumeric(PartStep) Then 
     Exit Sub 
    End If 
    Dim i, s, e, x As Integer 
    Dim rgePages As Range 
    Dim MyFile, LogFile, DocFile, DocName, MyName, MyPages, FilePath, objDoc 
    Set fso = CreateObject("scripting.filesystemobject") 

    Selection.GoTo What = wdGoToLine, Which = wdGoToFirst 

    Application.ScreenUpdating = False 

    ActiveDocument.Repaginate 
    MyPages = ActiveDocument.BuiltInDocumentProperties(wdPropertyPages) 

    DocFile = ActiveDocument.FullName 
    intPos = InStrRev(DocFile, ".") 
    MyName = Left(DocFile, intPos - 1) 

    If Not fso.folderexists(MyName) Then 
     fso.createfolder (MyName) 
     FilePath = MyName 
    Else 
     FilePath = MyName 
    End If 

    x = 0 
    'MsgBox MyPages 
    For i = 0 To MyPages Step PartStep 

     If i >= MyPages - PartStep Then 
      s = e + 1 
      e = MyPages 
     Else 
      s = i 
      e = i + (PartStep - 1) 
     End If 
     'MsgBox (i & " | " & s & " | " & e) 
     Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, count:=s 
     Set rgePages = Selection.Range 
     Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, count:=e 
     rgePages.End = Selection.Bookmarks("\Page").Range.End 
     rgePages.Select 
     Selection.Copy 
     x = x + 1 

     Set objDoc = Documents.Add 
     Selection.GoTo What = wdGoToLine, Which = wdGoToFirst 
     Selection.PasteAndFormat (wdFormatOriginalFormatting) 

     DocName = FilePath & "/" & "part" & Format(x, "000") & ".docx" 
     ActiveDocument.SaveAs2 FileName:=DocName, _ 
       FileFormat:=wdFormatXMLDocument, _ 
       CompatibilityMode:=14 

     ActiveDocument.Close savechanges:=wdDoNotSaveChanges 
    Next i 

    Set objDoc = Documents.Add 
    DocName = FilePath & "/" & "Merg" & ".docx" 
     ActiveDocument.SaveAs2 FileName:=DocName, _ 
       FileFormat:=wdFormatXMLDocument, _ 
       CompatibilityMode:=14 
    ActiveDocument.Close savechanges:=wdDoNotSaveChanges 

    Windows(1).Activate 
    ActiveDocument.Close savechanges:=wdDoNotSaveChanges 
    Dim oData As New DataObject 'object to use the clipboard 
    oData.SetText Text:=Empty 'Clear 
    oData.PutInClipboard 'take in the clipboard to empty it 
    Application.Quit 
End Sub 
sub test() 
    Call Spliter(50) 
end sub