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

tangqingfu

如果一篇文档中有多篇文章，请教如何以标题为标志，将这些文章分别提取出来作为单独文档。（这些文章的标题均为居中对齐，所有正文内容都不是居中对齐）

wdwc

不难，先按标题格式查找分节，然后把每节另存为一个单独文件，具体得看你的文档，用VBA可完成

相关内容论坛中有

wdwc

Sub TEST()

    On Error Resume Next
    Dim mySec As Section
    Dim myName As String
    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 "C:\" & myName & ".doc"
        ActiveDocument.Close False
    Next
End Sub

大致这个思路，可以根据自己需求更改代码，我的测试文档和生成文件在下面

JbHWOHK5.rar (21.72 KB, 下载次数: 36)

2008-5-18 22:39 上传

点击文件名下载附件
[求助]如何将文档里的多篇文章分别提取出来形成单独文档

tangqingfu

谢谢wdwc兄的代码，收藏学习！

tangqingfu

请教wdwc兄，如果要将生成的文档保存在自定义文件夹下，即不固定某一文件夹，而是可以自由选择文件夹。该如何修改代码？

wdwc

可以：

用inputbox 获得输入文件夹路径是一个简单办法。

Sub TEST()

    On Error Resume Next
    Dim mySec As Section
    Dim myPath, myName As String
    myPath = InputBox(prompt:="请填入欲保存文件夹路径" & Chr(13) & "如： C:\新建文件夹", Title:="填入路径") & "\"
    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
End Sub

注意文件夹路径可以通过文件夹地址栏复制获得，填写时结尾不要带 “\”。

tangqingfu

谢谢wdwc兄，测试成功！

用inputbox 获得输入文件夹路径是一个好办法。

不知能否采用弹出“浏览”界面，然后选择要保存的路径的方式？

我想这可能更人性化些。

wdwc

利用另存对话框获得欲保存文件夹路径，在另存时建议改一下文件名，以免在后面提取文章时由于文件名相同而出错误。

歪门邪道，勉强能用，请楼主测试

Sub TEST()

    On Error Resume Next
    Dim mySec As Section
    Dim myPath, myName As String
    Dialogs(wdDialogFileSaveAs).Show
    myPath = ActiveDocument.Path & "\"
    'MsgBox myPath
    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
End Sub

[此贴子已经被作者于2008-5-19 19:49:06编辑过]

tangqingfu

QUOTE:

以下是引用wdwc在2008-5-19 19:45:42的发言：
利用另存对话框获得欲保存文件夹路径，在另存时建议改一下文件名，以免在后面提取文章时由于文件名相同而出错误。

歪门邪道，勉强能用，请楼主测试

Sub TEST()

    On Error Resume Next
    Dim mySec As Section
    Dim myPath, myName As String
    Dialogs(wdDialogFileSaveAs).Show
    myPath = ActiveDocument.Path & "\"
    'MsgBox myPath
    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
End Sub

谢谢wdwc兄，可惜这样会多出一个文件。

wdwc

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

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

这回不多了。

[此贴子已经被作者于2008-5-20 7:25:35编辑过]