如何修改Word VBA宏提取Heading1文本作为拆分文档文件名？

你当前的核心问题是错误地将布尔值赋值给了存储标题的变量：Foundtext = Rng1.Find.Found这行代码里，Rng1.Find.Found返回的是「是否找到内容」的布尔值（True/False），而不是Heading1的文本内容。只要把这行改成读取Range的文本，再处理一下文件名的非法字符，就能实现需求。

修改步骤： #

1. 正确提取Heading1文本：
   把Foundtext = Rng1.Find.Found替换为读取Rng1的文本，同时清理换行符和文件名禁止的特殊字符（比如/\:*?"<>|），避免保存失败。
2. 移除手动输入文件名的逻辑：
   删除Ans$ = InputBox(...)及相关判断，直接用提取到的标题作为文件名。
3. 替换保存时的文件名变量：
   把所有bDoc.SaveAs中的Ans$换成处理后的Foundtext。

修改后的完整代码 #

Sub Hones()
    Dim aDoc As Document
    Dim bDoc As Document
    Dim Rng As Range
    Dim Rng1 As Range
    Dim Rng2 As Range
    Dim Counter As Long
    Dim Foundtext As String
    Dim illegalChars As Variant
    Dim char As Variant
    
    Set aDoc = ActiveDocument
    Set Rng1 = aDoc.Range
    Set Rng2 = Rng1.Duplicate
    
    Do
        With Rng1.Find
            .ClearFormatting
            .MatchWildcards = False
            .Forward = True
            .Format = True
            .Style = "Heading 1"
            .Execute
        End With
        
        If Rng1.Find.Found Then
            ' --- 修改1：正确提取Heading1文本并处理非法字符 ---
            Foundtext = Rng1.Text
            ' 去除换行符
            Foundtext = Replace(Foundtext, vbCr, "")
            Foundtext = Replace(Foundtext, vbLf, "")
            ' 替换文件名非法字符为下划线
            illegalChars = Array("/", "\", ":", "*", "?", """", "<", ">", "|")
            For Each char In illegalChars
                Foundtext = Replace(Foundtext, char, "_")
            Next char
            Debug.Print Foundtext ' 现在打印的是标题文本
            
            Counter = Counter + 1
            Rng2.Start = Rng1.End + 1
            With Rng2.Find
                .ClearFormatting
                .MatchWildcards = False
                .Forward = True
                .Format = True
                .Style = "Heading 1"
                .Execute
            End With
            
            If Rng2.Find.Found Then
                Rng2.Select
                Rng2.Collapse wdCollapseEnd
                Rng2.MoveEnd wdParagraph, -1
                Set Rng = aDoc.Range(Rng1.Start, Rng2.End)
                
                Set bDoc = Documents.Add
                bDoc.Content.FormattedText = Rng
                
                ' --- 修改2：用Foundtext替换Ans$作为文件名 ---
                bDoc.SaveAs Counter & ". " & Foundtext & ".docx", 16
                bDoc.Close
            Else
                ' 处理最后一个Heading1到文档末尾的内容
                If Rng2.End < aDoc.Range.End Then
                    Set bDoc = Documents.Add
                    Rng2.Collapse wdCollapseEnd
                    Rng2.MoveEnd wdParagraph, -2
                    Set Rng = aDoc.Range(Rng2.Start, aDoc.Range.End)
                    bDoc.Content.FormattedText = Rng
                    
                    ' --- 修改3：用Foundtext替换Ans$作为文件名 ---
                    bDoc.SaveAs Counter & ". " & Foundtext & ".docx", wdFormatDocumentDefault
                    bDoc.Close
                End If
            End If
        End If
    Loop Until Not Rng1.Find.Found
End Sub

说明 #

• 处理非法字符是因为Windows文件名不允许包含/\:*?"<>|这些符号，直接用下划线替换可以避免保存报错。
• 去除换行符是因为Heading1的文本可能自带段落标记，导致文件名出现多余的换行。

内容的提问来源于stack exchange，提问作者adsnape