VBA如何将WORD中内容按标题进行拆分成多个文档

jxy2515

一闪流溢 发表于 2022-1-6 14:58
直接用主控文档拆分就可以。大纲视图-全选-显示文档-创建-保存

但是这种方法拆分出来的文档格式会变化，这个问题有解决方案么？谢谢！

jxy2515

ming0018 发表于 2021-2-18 15:09
大纲里面有个按标题拆分文档的功能选项

但是这种方法拆分出来的文档格式会变化，这个问题有解决方案么？谢谢！

chenzhen88

tanshuizhu 发表于 2022-1-5 19:56
您这个解决了吗？为什么我运行这个word后就没有呢

你的找到了吗，我没找到在哪啊

chenzhen88

tanshuizhu 发表于 2022-1-5 19:56
您这个解决了吗？为什么我运行这个word后就没有呢

我的也是找不到拆分后的

沐沐沐666

betelehe 发表于 2021-3-22 14:12

能更新一下么，不能用

tanshuizhu

Sub 按一级标题拆分文档()
   
    Dim doc As Document, newDoc As Document, para As Paragraph, title1 As String
    Selection.HomeKey Unit:=wdStory
    ReDim arr(0 To 0)
    arr(0) = 0
    Set doc = ActiveDocument
    总字数 = doc.Range.Characters.Count
    Path = doc.Path & "\" '获取当前文档
    ' 遍历当前文档中的每个段落
    For i = 1 To doc.Paragraphs.Count
        ' 判断段落是否为一级标题
        If doc.Paragraphs(i).OutlineLevel = 1 Then
            r = doc.Paragraphs(i).Range.Start
            ReDim Preserve arr(0 To n)
            arr(n) = r
            n = n + 1
        End If
    Next
    'Stop
    For j = 0 To UBound(arr) '1维数组不用加维度
        For Each para In doc.Paragraphs
            If para.OutlineLevel = 1 Then
                title1 = para.Range.Text
                title1 = 截文本(title1)
                ' 去除标题中的非法字符，以便作为文件名使用
                title1 = Replace(title1, "*", "")
                title1 = Replace(title1, "/", "")
                title1 = Replace(title1, "\", "")
                title1 = Replace(title1, ":", "")
                title1 = Replace(title1, "?", "")
                title1 = Replace(title1, Chr(34), "")
                title1 = Replace(title1, "<", "")
                title1 = Replace(title1, ">", "")
                title1 = Replace(title1, "|", "")
                title1 = Trim(title1)
                If j + 1 > UBound(arr) Then
                    doc.Range(arr(UBound(arr)), 总字数).Select
                Else
                    st = arr(j)
                    ed = arr(j + 1)
                    doc.Range(st, ed).Select 'range从0下标开始,注意!!!
                End If
                Selection.Copy
                Set newDoc = Documents.Add
                ' 设置新文档的标题
                Selection.Paste
                Selection.TypeBackspace
                ' 替换为你想保存的目录
                newDoc.SaveAs2 Path & title1 & ".docx"
                newDoc.Close 0
                j = j + 1
            End If
        Next
    Next
   
End Sub

Function 截文本(x)
   
    截文本 = Left(x, Len(x) - 1)
   
End Function