求助：如何将一个多页的word文档按页批量生成新的单个文件

413191246se · 发表于 2021-2-2 23:11

* 楼主，附件文档第一段落首行有缩进并非居中，请改正之。
* 请打开要拆分的文档试用下面的宏：（此宏可能不适合有表格的文档！拆分结果请见"D:\TextSplit"）

Sub TextSplit()
Dim doc As Document, i&, p&, s&, t$, j&, k$, y$, x$
With ActiveDocument
y = .FullName
p = .ComputeStatistics(wdStatisticPages)
k = (Split(y, ".")(1))
Do
i = i + 1
With Selection
.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=i + 1
If Asc(.Previous) <> 12 Then .InsertBreak Type:=wdSectionBreakNextPage
End With
Loop Until i = p - 1
s = .Sections.Count
End With
Do
Set doc = ActiveDocument
With doc
j = j + 1
.Sections(j).Range.Select
If j = s Then
.Range(Start:=0, End:=Selection.Start).Delete
Else
.Range(Start:=Selection.End, End:=.Content.End).Delete
If j > 1 Then .Range(Start:=0, End:=Selection.Start).Delete
End If
.Content.Find.Execute "^b", , , 0, , , , , , "", 2
Do While .Paragraphs.Last.Range.Text = vbCr
.Paragraphs.Last.Range.Delete
Loop
Selection.HomeKey 6
ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitBestFit
If Len(Dir("D:\TextSplit", 16)) = 0 Then MkDir "D:\TextSplit"
x = .Paragraphs(3).Range.Text
x = Replace(x, vbCr, "")
If k = "docx" Then
.SaveAs2 FileName:="D:\TextSplit" & "" & x & ".docx", FileFormat:=wdFormatXMLDocument
Else
.SaveAs2 FileName:="D:\TextSplit" & "" & x & ".doc", FileFormat:=wdFormatDocument
End If
.Close
If j = s Then Exit Do
Documents.Open FileName:=y
End With
Loop
t = "D:\TextSplit"
MsgBox "Completed!" & vbCr & "Save Path - " & t, 0 + 48
End Sub

复制代码

Wilber_lin · 发表于 2021-2-5 15:04

413191246se 发表于 2021-2-2 23:11
* 楼主，附件文档第一段落首行有缩进并非居中，请改正之。
* 请打开要拆分的文档试用下面的宏：（此宏可能 ...

谢谢！！！！！！！！！

Wilber_lin · 发表于 2021-2-10 17:54

wangqh8203 发表于 2021-2-2 20:35
论坛里有个高手写过一段代码，可以根据邮件合并每份单独保存文件。
Sub myMailMerge()
'按邮件合并每个记 ...

谢谢，已解决。

Wilber_lin · 发表于 2021-2-10 17:54

413191246se 发表于 2021-2-2 23:11
* 楼主，附件文档第一段落首行有缩进并非居中，请改正之。
* 请打开要拆分的文档试用下面的宏：（此宏可能 ...

谢谢，已解决。

wang-way · 发表于 2021-2-11 00:42

我来凑个热闹练练手

Sub 按交办函拆分()
Dim p As Paragraph
Dim doc As Document
Dim folderPath, fileName
folderPath = ActiveDocument.Path & Application.PathSeparator
For Each p In ActiveDocument.Paragraphs
If InStr(p.Range.Text, "[2021]第") > 0 Then
fileName = Left(p.Range.Text, Len(p.Range.Text) - 1) & ".docx"
Debug.Print fileName
p.Range.Select
Selection.MoveStart wdParagraph, -2
Selection.MoveEnd wdParagraph, 7
Selection.Copy
Set doc = Documents.Add
doc.Activate
Selection.Paste
doc.SaveAs2 folderPath & fileName
doc.Close True
'Stop
End If
Next
Set p = Nothing
Set doc = Nothing
End Sub

复制代码

413191246se · 发表于 2021-2-11 10:43

楼上朋友，你好！试用了你的宏，结果正确！但也有几点建议：1、p、doc 不是对象，有必要释放吗？2、个别语句是不需要的，如“debug”，我没看有什么显示，当然我也不知道它是干什么的；还有已经另存为了，直接 close 即可，不必 true。3、新建文档后，直接就是活动文档了，就不必激活了。4、会用 .MoveStart/.MoveEnd，这很不错！5、文档拆分，我个人认为，还是有“节”(Section)时比较好，因为可以保持格式；复制/粘贴可能不会保持格式。谢谢！

wang-way · 发表于 2021-2-11 16:35

413191246se 发表于 2021-2-11 10:43
楼上朋友，你好！试用了你的宏，结果正确！但也有几点建议：1、p、doc 不是对象，有必要释放吗？2、个别语 ...

谢谢指导，我对word对象模型，方法都不是很熟悉。但是p和doc为什么不是对象？

413191246se · 发表于 2021-2-11 21:55

楼上朋友，你好！p/doc 是不是对象，真不清楚。可能是我说错了，但没必要释放吧！因为从未见人这么做过，似乎没必要。

wang-way · 发表于 2021-2-11 22:32

413191246se 发表于 2021-2-11 21:55
楼上朋友，你好！p/doc 是不是对象，真不清楚。可能是我说错了，但没必要释放吧！因为从未见人这么做过，似 ...

我无言以对，但是向你学习

413191246se · 发表于 2021-2-12 13:58

朋友，新年快乐！我也向你学习！（有些我也不知道是对象不是对象，反正，我就是会用，经常用。）

		自动登录	找回密码
密码			免费注册

[求助] 求助：如何将一个多页的word文档按页批量生成新的单个文件