按照分节符拆分word文档求助高人

qinlei1024

Sub test()
   Dim mySec As Section, i As Long, myDoc As Document, SourceDoc As Document
   Set SourceDoc = ActiveDocument
   For Each mySec In SourceDoc.Sections
      If mySec.PageSetup.SectionStart = wdSectionNewPage And mySec.Index > 1 Then
         Set myDoc = Application.Documents.Add
         myDoc.Content.FormattedText = SourceDoc.Range(i, mySec.Range.Start - 1)
         myDoc.Content.Sections.Last.PageSetup.SectionStart = _
                  SourceDoc.Range(i, mySec.Range.Start - 1).Sections.Last.PageSetup.SectionStart
         i = mySec.Range.Start
      End If
      If mySec.Index = SourceDoc.Sections.Count Then
         Set myDoc = Application.Documents.Add
         myDoc.Content.FormattedText = SourceDoc.Range(i, SourceDoc.Content.End)
         myDoc.Content.Sections.Last.PageSetup.SectionStart = _
                  SourceDoc.Range(i, SourceDoc.Content.End).Sections.Last.PageSetup.SectionStart
      End If
   
   Next
End Sub
求帮忙的这个可以按照节拆分 但是不能自动保存  求高人改改 保存在打开的文件夹中 谢谢了

psystyle

标记一下，哪位高人解决？

zhanglei1371

Sub test()
   Dim mySec As Section, i As Long, myDoc As Document, SourceDoc As Document
   Set SourceDoc = ActiveDocument
   ii = 0
   For Each mySec In SourceDoc.Sections
      If mySec.PageSetup.SectionStart = wdSectionNewPage And mySec.Index > 1 Then
         Set myDoc = Application.Documents.Add
         myDoc.Content.FormattedText = SourceDoc.Range(i, mySec.Range.Start - 1)
         myDoc.Content.Sections.Last.PageSetup.SectionStart = _
                  SourceDoc.Range(i, mySec.Range.Start - 1).Sections.Last.PageSetup.SectionStart
         i = mySec.Range.Start
   myDoc.SaveAs "c:\" & "分节" & ii & ".doc"
   myDoc.Close True
      End If
      If mySec.Index = SourceDoc.Sections.Count Then
         Set myDoc = Application.Documents.Add
         myDoc.Content.FormattedText = SourceDoc.Range(i, SourceDoc.Content.End)
         myDoc.Content.Sections.Last.PageSetup.SectionStart = _
                  SourceDoc.Range(i, SourceDoc.Content.End).Sections.Last.PageSetup.SectionStart
   myDoc.SaveAs "c:\" & "分节" & ii & ".doc"
   myDoc.Close True
      End If
Debug.Print ii
      ii = ii + 1
   Next
End Sub

psystyle

测试了一下，好像少了一节，能否用每一节的第一行来保存呢？

zhanglei1371

上面方法太繁琐了，用简单的点的吧：
Sub 按节保存()
Dim s As Section
    For Each s In ActiveDocument.Sections
    aa = ActiveDocument.Name
        s.Range.Copy
        Documents.Add.Content.Paste
        Dim i As Paragraph
        For Each i In ActiveDocument.Content.Paragraphs
        If Len(i.Range.Sentences(1)) > 2 Then
        sa = i.Range.Sentences(1)
        Exit For
        End If
        Next
        Selection.EndKey wdStory
        Selection.MoveLeft wdCharacter, 1
        Selection.Delete
        ActiveDocument.SaveAs "c:\" & sa & ".doc"
        ActiveDocument.Close True
    Next
End Sub

真子0320

zhanglei1371 发表于 2013-5-2 13:49
Sub test()
   Dim mySec As Section, i As Long, myDoc As Document, SourceDoc As Document
   Set Sou ...

你好。试了一下果然好用，但是唯一不好的就是存出来是2003版 的，现在都用2010版的。高手能否修改一下呢？谢谢

daocao2003

谢谢5楼的方法，很好用！

dogingate

后缀doc改成docx不就好了

dogingate

比如，这样将每一节保存为节号，当然你可以保存为每一节的名字，自己改代码
Sub 按节保存()
Dim asection As Section
Dim folderPath As String
Dim k As Integer

k = 1
Set doc = ActiveDocument
folderPath = ActiveDocument.Path

For Each asection In doc.Sections
    asection.Range.Copy
    Set newdoc = Documents.Add
    newdoc.Content.Paste
    newdoc.SaveAs folderPath & "\" & CStr(k) & ".docx"
    newdoc.Close True
    k = k + 1
Next asection
End Sub

dogingate

刚好要用，就改了下，供参考
Sub 按节保存()
Dim asection As Section
Dim folderPath As String
Dim fileName As String
Dim sectionCount As Integer
Dim k As Integer

Set doc = ActiveDocument
folderPath = ActiveDocument.Path

sectionCount = doc.Sections.Count

For k = 1 To sectionCount - 1
   
    Set asection = doc.Sections(k)
    asection.Range.Select
    Selection.Copy
    Set newdoc = Documents.Add
    newdoc.Content.Paste
   
    ys = k Mod 2
    If ys <> 0 Then
        fileName = Trim(asection.Range.Paragraphs(1).Range)
        fileName = Left(fileName, Len(fileName) - 1)
    Else
        fileName = fileName & "桥梁资料卡"
    End If
   
    newdoc.SaveAs folderPath & "\" & fileName & ".docx"
   
    newdoc.Close True
   
Next k
End Sub