如何通过代码将含有绿色字体文本所在的段落提取出来？

tangqingfu · 发表于 2019-5-25 15:46

本帖最后由 tangqingfu 于 2019-5-25 15:59 编辑

请教如何通过代码将所有含有绿色字体文本所在的段落提取到新文档中？

413191246se · 发表于 2019-5-25 23:58

Sub test提取绿色段落到新建文档()
Dim s$
With ActiveDocument.Content.Find
.ClearFormatting
.Text = ""
.Font.Color = wdColorGreen
.Forward = True
.MatchWildcards = True
Do While .Execute
s = s & .Parent.Paragraphs(1).Range.Text
Loop
End With
Documents.Add.Content = s
End Sub

复制代码

413191246se · 发表于 2019-5-26 00:23

唐兄：楼上代码作废！因为如果每个段落含有一个绿色字符，那么楼上代码是正确的！但是，如果某个段落含有两个或以上绿色字符时，请应用下面的宏：

Sub test提取绿色段落到新建文档()
Dim r As Range, a As Range, s$
Set r = ActiveDocument.Content
Set a = ActiveDocument.Content
With r.Find
.ClearFormatting
.Text = ""
.Font.Color = wdColorGreen
.Forward = True
.MatchWildcards = True
Do While .Execute
With .Parent
s = s & .Paragraphs(1).Range.Text
If r.Paragraphs(1).Range.End = a.End Then Exit Do
r.SetRange Start:=r.Next(4, 1).Start, End:=a.End
End With
Loop
End With
Documents.Add.Content = s
End Sub

复制代码

相见是缘8 · 发表于 2019-5-26 08:08

本帖最后由相见是缘8 于 2019-5-26 08:31 编辑

期待……！

小花鹿 · 发表于 2019-5-26 13:31

413191246se 发表于 2019-5-25 23:58

用你的代码改一下：
Sub test提取绿色段落到新建文档()
Dim s$, mydoc, ph
Set mydoc = Documents.Add
For Each ph In ThisDocument.Paragraphs
      With ph.Range.Find
         .ClearFormatting
         .Text = ""
         .Font.Color = wdColorGreen
         .Forward = True
         .MatchWildcards = True
         If .Execute Then
            .Parent.Paragraphs(1).Range.Copy
            Selection.EndKey Unit:=wdStory
            Selection.Paste
         End If
      End With
Next ph
End Sub

相见是缘8 · 发表于 2019-5-26 14:18

小花鹿发表于 2019-5-26 13:31
用你的代码改一下：
Sub test提取绿色段落到新建文档()
Dim s$, mydoc, ph

老师的代码，好像提取不了！

tangqingfu · 发表于 2019-5-26 15:24

相见是缘8 发表于 2019-5-26 14:18
老师的代码，好像提取不了！

代码测试通过，可以提取。

duquancai · 发表于 2019-5-26 16:24

本帖最后由 duquancai 于 2019-5-26 21:18 编辑

tangqingfu 发表于 2019-5-26 15:24
代码测试通过，可以提取。

周末，我也来凑个热闹！！！屏蔽掉内容重复的段落。

Sub main()
Dim flag As Boolean
With ActiveDocument.Content.Find
.Font.Color = wdColorGreen
Do While .Execute
If Not flag Then
Dim doc As Document, d As Object, p As Range
Set doc = Documents.Add
Set d = CreateObject("Scripting.Dictionary")
Set p = .Parent.Paragraphs(1).Range
doc.Content.FormattedText = p.FormattedText
d(p.Text) = 0: .Parent.Move 4: flag = True
Else
Set p = .Parent.Paragraphs(1).Range
If Not d.Exists(p.Text) Then
doc.Bookmarks("\EndOfDoc").Range.FormattedText = p.FormattedText
End If
d(p.Text) = 0: .Parent.Move 4
End If
Loop
End With
End Sub

复制代码

duquancai · 发表于 2019-5-26 17:09

tangqingfu 发表于 2019-5-26 15:24
代码测试通过，可以提取。

如果提取的段落到新文档中不得有重复段落出现，那么需要do循环中增加一个字典进行判断！！！

小花鹿 · 发表于 2019-5-26 17:58

相见是缘8 发表于 2019-5-26 14:18
老师的代码，好像提取不了！

大家玩玩，讨论一下

		自动登录	找回密码
密码			免费注册

[求助] 如何通过代码将含有绿色字体文本所在的段落提取出来？

评分

评分

评分

评分