[求助]如何将文档里的多篇文章分别提取出来形成单独文档

tangqingfu

谢谢wdwc兄，现在可以了！

tangqingfu

QUOTE:

以下是引用wdwc在2008-5-20 7:15:34的发言：

在后边加上一个删除语句就可以了

Sub TEST()

    On Error Resume Next
    Dim mySec As Section
    Dim myPath, myName As String
lc: If Dialogs(wdDialogFileSaveAs).Show <> -1 Then
    MsgBox "请选择保存路径！"
    GoTo lc
    End If
    myPath = ActiveDocument.Path & "\"
    Selection.HomeKey wdStory
    With Selection.Find
        .ClearFormatting
        .ParagraphFormat.Alignment = wdAlignParagraphCenter
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchWildcards = False
    End With
    Do While Selection.Find.Execute = True
        Selection.InsertBreak Type:=wdSectionBreakNextPage
        Selection.MoveDown wdLine, 3
    Loop
    For Each mySec In ActiveDocument.Sections
        mySec.Range.Select
        Selection.Copy
        Documents.Add
        Selection.Paste
        myName = Mid(ActiveDocument.Paragraphs(1).Range.Text, 1, Len(ActiveDocument.Paragraphs(1).Range.Text) - 1)
        ActiveDocument.SaveAs myPath & myName & ".doc"
        ActiveDocument.Close False
    Next
    myName = ActiveDocument.FullName
    ActiveDocument.Close False
    Kill myName
End Sub

这回不多了。

想学习一下上面的代码，能否请wdwc兄逐句进行注释说明一下？

wdwc

Sub TEST()
    On Error Resume Next                 '出现错误从下一条语句执行
    Dim mySec As Section                 '定义mySec为 节
    Dim myPath, myName As String         '定义myPath为字符串，以获得保存路径，myName为字符串，以获得文件名

lc: If Dialogs(wdDialogFileSaveAs).Show <> -1 Then  '另存语句：如果在显示的另存框中没有点击确定，哪么
    MsgBox "请选择保存路径！" '显示对话框进行提醒
    GoTo lc '跳转到另存语句（所以只要你没另存这里就总会提醒你，直到另存，这个另存要保存在生成文件欲保存的文件夹下）
    End If
    myPath = ActiveDocument.Path & "\"    '获得当前活动文档的路径，由于当前活动文档被保存在生成文件欲保存的文件夹下，所以二者是同一的。
    Selection.HomeKey wdStory    '将光标返回之文档开头
'''''''''''以下查找格式居中的文字并加入分节符
    With Selection.Find    '查找
        .ClearFormatting   '清楚查找框格式
        .ParagraphFormat.Alignment = wdAlignParagraphCenter  '设置查找框格式为段落居中对齐
        .Text = ""  '查找内容保持空白
        .Replacement.Text = "" '替换内容保持空白
        .Forward = True '向下查找
        .Wrap = wdFindContinue '循环查找
        .Format = True '查找格式为真，此句重要
        .MatchWildcards = False '不使用通配符
    End With
    Do While Selection.Find.Execute = True   '当查找到段落居中的文字时
        Selection.InsertBreak Type:=wdSectionBreakNextPage  '插入分节符
        Selection.MoveDown wdLine, 3  '光标向下移动3行
    Loop '循环
'''''''''''''以下提取文章
    For Each mySec In ActiveDocument.Sections ' 在活动文档中的所有节中逐个循环
        mySec.Range.Select '选中该节
        Selection.Copy '复制该节
        Documents.Add '新建文档
        Selection.Paste     '粘贴至新建文档
        myName = Mid(ActiveDocument.Paragraphs(1).Range.Text, 1, Len(ActiveDocument.Paragraphs(1).Range.Text) - 1)     '定义文件名为第一段文字（这里用了函数，去掉了段落标记，否则会出现保存错误）
        ActiveDocument.SaveAs myPath & myName & ".doc"     '活动文档另存
        ActiveDocument.Close False     '关闭活动文档
    Next     '处理下一个节
''''''''''''以下删除多余文档
    myName = ActiveDocument.FullName     '当所有节都另存之后，获得活动文档的全文件名
    ActiveDocument.Close False     '关闭活动文档
    Kill myName     '删除指定文档
End Sub

建议你按 F8 逐语句执行，一步一步看一下，自然明白了

[此贴子已经被作者于2008-5-24 8:39:20编辑过]

tangqingfu

谢谢wdwc兄，收藏学习中……

[此贴子已经被作者于2008-5-24 9:19:25编辑过]

cycyaya

谢谢分享。

ammyc

好好学习天天向上

cycyaya

wdwc 发表于 2008-5-24 08:35
Sub TEST()&nbsp;&nbsp;&nbsp; On Error Resume Next&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nb ...

大神你好，我用你这个代码想拆分我一个文档，不知为什么拆分不了，能不能帮我看看？万分感谢！
想以标题为界，拆分成每个部门的工资表。

2016年10月工资表（样版）word格式.zip (23.44 KB, 下载次数: 4)

2017-1-16 21:12 上传

点击文件名下载附件