如何提取红色加下划线的单词，并标上序号

zzpsx

如何提取红色加下划线的单词，并标上序号.rar (3.85 KB, 下载次数: 15)

2018-2-15 12:49 上传

点击文件名下载附件

先说说我的土办法，在最后一个红词上右键，选择格式相似的文本，红词均被选中，然后复制到另外一个空白文档中给这10词标号。

leikaiyi123

Sub 提取红色加下划线的单词并标上序号()
    Dim i, arr(100)
    i = 0
    With ActiveDocument.Content.Find
        .Font.Underline = wdUnderlineSingle
        .Font.Color = wdColorRed
        Do While .Execute("[A-Za-z]{1,}", , , 1)
            With .Parent
                arr(i) = .Text
                i = i + 1
            End With
        Loop
    End With
    Selection.EndKey Unit:=wdStory
    For i = 0 To UBound(arr)
        If arr(i) <> "" Then Selection.TypeText Text:=i + 1 & "." & arr(i) & "  "
    Next
End Sub

zzpsx

leikaiyi123 发表于 2018-2-15 20:22
Sub 提取红色加下划线的单词并标上序号()
    Dim i, arr(100)
    i = 0

谢谢高手，好代码，太感谢了

leikaiyi123

优化下：
Sub 提取红色加下划线的单词并标上序号()
    Dim i, arr() As Variant
    i = 0
    With ActiveDocument.Content.Find
        .Font.Underline = wdUnderlineSingle
        .Font.Color = wdColorRed
        Do While .Execute("[A-Za-z]{1,}", , , 1)
            With .Parent
                i = i + 1
                ReDim Preserve arr(i)
                arr(i) = .Text
            End With
        Loop
    End With
   
    Selection.EndKey Unit:=wdStory
    For i = 1 To UBound(arr)
        Selection.TypeText Text:=i & "." & arr(i) & "  "
    Next
End Sub

zzpsx

leikaiyi123 发表于 2018-2-15 21:24
优化下：
Sub 提取红色加下划线的单词并标上序号()
    Dim i, mystr$, arr() As Variant

谢谢高手的精益求精

13907933959

leikaiyi123 发表于 2018-2-15 20:22
Sub 提取红色加下划线的单词并标上序号()
    Dim i, arr(100)
    i = 0

网友新年好！
现提取的单词它是连在英文的后面，能否让它另起一行？

leikaiyi123

在文末先按一下回车再提取，或在    Selection.EndKey Unit:=wdStory之后加一句按回车的代码。

13907933959

leikaiyi123 发表于 2018-2-16 08:21
在文末先按一下回车再提取，或在    Selection.EndKey Unit:=wdStory之后加一句按回车的代码。

好的，加这一句就好了。谢谢！
Selection.TypeParagraph

tangqingfu

谢谢分享！

tangqingfu

leikaiyi123 发表于 2018-2-15 21:24
优化下：
Sub 提取红色加下划线的单词并标上序号()
    Dim i, arr() As Variant

再次学习，谢谢leikaiyi123兄分享