如何实现word导航中“选中标题和内容”？

snow653124

使用中用到这个功能，不知道如何搞

就是循环选择指定标题级别的标题及内容，导航视图中的“选中标题及内容”
有示例文档，选择二级标题及其内容，能循环选择即可。
感谢

如何选择标题及内容.rar (10.48 KB, 下载次数: 13)

2022-9-7 21:30 上传

点击文件名下载附件

413191246se

楼主，大纲视图中可以选择仅显示到二级标题。

snow653124

413191246se 发表于 2022-9-8 08:03
楼主，大纲视图中可以选择仅显示到二级标题。

不是显示，是循环选择二级标题及标题下内容，使其处于选择状态，用vba

413191246se

* 楼主，请将下面的两个宏复制粘贴到 VBE 中，再执行《a0908_HotKey》宏，打开文档，按 F8 键即可。

1. Sub a0908_HotKey()
   
2.     KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF8), KeyCategory:=wdKeyCategoryMacro, Command:="a0908_FindTitle"
   
3.     MsgBox "请将光标放在标题段落中！按热键 F8 即可！", 0 + 48
   
4. End Sub
   
5. Sub a0908_FindTitle()
   
6.     Dim s$
   
7.     With Selection
   
8.         s = .Paragraphs(1).Style
   
9.         .Start = .Paragraphs(1).Range.Start
   
10.         With .Find
    
11.             .ClearFormatting
    
12.             .Text = ""
    
13.             .Replacement.Text = ""
    
14.             .Style = s
    
15.             .Forward = True
    
16.             .MatchWildcards = True
    
17.             If Not s = "标题 1" Then s = "标题 [123]"
    
18.             Do While .Execute
    
19.                 With .Parent
    
20.                     Do
    
21.                         .MoveEnd 4, 1
    
22.                         If .Paragraphs.Last.Range.End = ActiveDocument.Content.End Then Exit Sub
    
23.                     Loop Until .Paragraphs.Last.Range.Style Like s
    
24.                     .MoveEnd 4, -1
    
25.                     Exit Sub
    
26.                 End With
    
27.             Loop
    
28.         End With
    
29.     End With
    
30. End Sub

复制代码

snow653124

逐行向下判断，判断最后一个字符的标题等级
感谢

snow653124

Sub 根据大纲选择标题及内容()
    Dim n%, k%, i As Long, p As Long
    Application.ScreenUpdating = False
    With Selection.Find
        .ClearFormatting
        .text = "" '此处设置提取的名字，跟style可选择或组合使用
        .Style = wdStyleHeading4 '此处设置选择大纲级别
        .Forward = True
        Do While .Execute
            n = Selection.Range.Paragraphs.OutlineLevel
        '判断起点
            If Selection.Range.Paragraphs.OutlineLevel = n Then
                起点 = Selection.Range.Start
                Selection.GoTo wdGoToHeading, wdGoToNext, 1
            Else
                Do Until Selection.Range.Paragraphs.OutlineLevel = n
                    Selection.GoTo wdGoToHeading, wdGoToNext, 1
                Loop
                起点 = Selection.Range.Start
                Selection.GoTo wdGoToHeading, wdGoToNext, 1
            End If
    '判断终点
            If Selection.Range.Paragraphs.OutlineLevel = n Or Selection.Range.Paragraphs.OutlineLevel < n Then
                终点 = Selection.Range.Start
                '若提取的标题是文档最后一个
                If 起点 = 终点 Then 终点 = ActiveDocument.Content.End: GoTo 最后一个标题
                Selection.GoTo wdGoToHeading, wdGoToNext, 1
            Else
                Do Until Selection.Range.Paragraphs.OutlineLevel < n Or Selection.Range.Paragraphs.OutlineLevel = n
                    i = Selection.Range.Start
                    Selection.GoTo wdGoToHeading, wdGoToNext, 1
                    p = Selection.Range.Start
                    '判断光标不动，即到最后一个标题，跳出，设置终点
                    If i = p Then
                        终点 = ActiveDocument.Content.End
                        GoTo 最后一个标题
                    End If
                Loop
                终点 = Selection.Range.Start
                Selection.GoTo wdGoToHeading, wdGoToNext, 1
            End If
最后一个标题:
    '选择
        ActiveDocument.Range(起点, 终点).Select
        Selection.Range.HighlightColorIndex = wdYellow '选择后处理
        Selection.Collapse 0
        Loop
    End With
    Application.ScreenUpdating = True
End Sub

413191246se

楼主，厉害啊！

snow653124

413191246se 发表于 2022-9-13 18:30
楼主，厉害啊！

瞎胡写的 我只会基础操作

snow653124

413191246se 发表于 2022-9-13 18:30
楼主，厉害啊！

我其实是想实现另一个功能，即从一大堆文档里面，提取所需的部分，已经实现了，从excel读取关键词，然后按关键词选择，组合到新文档中，我的都是解决自己工作中的问题，应该是不具有普遍性

Sub 根据excel调整顺序()
'-------------------------------------------------------------------
'根据excel关键词顺序，重排，大纲需为style的标题样式才好
'-------------------------------------------------------------------
    Dim i%, nam$, n$, u%
    nam = Split(ActiveDocument.Name, ".")(0)
    Set 连接 = CreateObject("excel.application")
    Set 表格 = 连接.Workbooks.Open("e:\人员排序.xls")
    连接.Visible = False
    Application.Documents.Add.SaveAs2 FileName:="e:\人员排序.docx"
    Windows(nam).Activate
    i = 1
    Do While 表格.Worksheets("sheet1").Range("a" & i) <> ""
        n = 表格.Worksheets("sheet1").Range("a" & i).Value
        With Selection.Find
            .ClearFormatting
            .text = n
            .Wrap = wdFindContinue
            If .Execute = True And Selection.Range.Paragraphs.OutlineLevel < 10 Then
                Selection.Expand 4
                Selection.Collapse 1
                起点 = Selection.Range.Start
                u = Selection.Range.Paragraphs.OutlineLevel
                Selection.GoTo wdGoToHeading, wdGoToNext, 1
                If Selection.Range.Paragraphs.OutlineLevel < u Or Selection.Range.Paragraphs.OutlineLevel = u Then
                    终点 = Selection.Range.Start
                        If 起点 = 终点 Then 终点 = ActiveDocument.Content.End
循环:
                            ActiveDocument.Range(起点, 终点).Copy
                            Windows("人员排序").Activate
                            Selection.EndKey wdStory
                            Selection.PasteAndFormat wdFormatOriginalFormatting
                            Windows(nam).Activate
                    i = i + 1
                Else
                    Do Until Selection.Range.Paragraphs.OutlineLevel < u Or Selection.Range.Paragraphs.OutlineLevel = u
                          Selection.GoTo wdGoToHeading, wdGoToNext, 1
                    Loop
                    GoTo 循环
                End If
                    
            End If
        End With
    Loop
End Sub

413191246se

Excel VBA 我也略看了看帮助，但工作中几乎不需要 Excel，只用 Word。所以，我只对 Word VBA 感兴趣。
楼主 解决工作中的实际问题，提高效率，很好呀！ 我的最大兴趣是 Word VBA 公文自动排版。