vba 用于一对多拆分 Word 文档的宏
声明:本页面是StackOverFlow热门问题的中英对照翻译,遵循CC BY-SA 4.0协议,如果您需要使用它,必须同样遵循CC BY-SA许可,注明原文地址和作者信息,同时你必须将它归于原作者(不是我):StackOverFlow
原文地址: http://stackoverflow.com/questions/2224434/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Macro for one-to-many splitting of Word documents
提问by Alex R
I have a Word document which is several hundred pages long.
我有一个几百页长的 Word 文档。
I would like to use a macro to automatically create about a dozen or so sub-documents based on certain rules (mainly, occurrence of certain strings in each Section).
我想使用宏根据某些规则(主要是每个部分中出现某些字符串)自动创建大约十几个子文档。
Is this possible? What VBA functions should I read-up on? Does anybody know of any code examples which are even remotely similar and which I may be able to customize for my purposes?
这可能吗?我应该阅读哪些 VBA 函数?有没有人知道任何代码示例甚至远程相似并且我可以根据我的目的进行自定义?
Thanks
谢谢
回答by user998303
It took me a while to figure out how to do this, even with the KB article.
即使使用知识库文章,我也花了一段时间才弄清楚如何做到这一点。
Firstly, you need to put the macro into Normal.dotm... Open C:\Users\Yourname\AppData\Roaming\Microsoft\Templates\Normal.dotm in Word, press Alt-F11, and paste the following into Module1:
首先,您需要将宏放入 Normal.dotm... 在 Word 中打开 C:\Users\Yourname\AppData\Roaming\Microsoft\Templates\Normal.dotm,按 Alt-F11,然后将以下内容粘贴到 Module1 中:
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
Save the Normal.dotm file.
保存 Normal.dotm 文件。
Executing this code will split a document made up of multiple sections into multiple documents in the C:\Destination directory and then close down Word.
执行此代码会将一个由多个部分组成的文档拆分为 C:\Destination 目录中的多个文档,然后关闭 Word。
You can execute this from the command line via:
您可以通过以下方式从命令行执行此操作:
"c:\Program Files\Microsoft Office\Office12\WINWORD.EXE" /mBreakOnSection "C:\Path to Source\Document with multiple sections.doc"
To process all the .doc files in a directory, create a batch file as follows, and execute it:
要处理一个目录中的所有.doc文件,请按如下方式创建一个批处理文件,并执行它:
@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
回答by Ashish Saini
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
回答by amini gazar
Split word document by page counter for example use 50 to steps
按页面计数器拆分word文档例如使用50步
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