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

wdpfox

duquancai 发表于 2019-5-26 17:09
如果提取的段落到新文档中不得有重复段落出现，那么需要do循环中增加一个字典进行判断！！！

老师具有编程思维，考虑得比较全面，尽量减少了“坑”的数量。

                                        莫愁前路无知己，天下谁人不识君！海内存知己，天涯若比邻！  

小花鹿

相见是缘8 发表于 2019-5-27 14:27
老师你的电脑也提取不了，是吧？可小花鹿老师说在03的电脑试了代码没问题，可提取，难道和电脑系统的不同 ...

我专门找了一个电脑，WINXP+OFFICE2003，试验结果绝对没问题，你们不出结果，我也不知道啥原因，郁闷

小花鹿

2楼的代码主要是如果一个段落有两处绿色字符，就会重复提取此段落，加上.Parent.Move 4 就没问题了
一个WORD文档有两个相同的段落也是可以理解的，只要不是重复提取同一个段落就行了
当然，如果想排除重复的段落，另当别论，只能用字典了

413191246se

* 向 小花鹿 老师 道歉！对不起！您的代码我和 相见 一样，没得到正确结果，我猜是我俩儿的水平有问题，不会用，您的代码可能没有问题。
*
* 相见，不好意思！实际上我的水平也很低，哪里敢和 杜先生 相提并论呢！？ 我仅仅算刚刚 VBA 入门，杜先生 却是大神啊！天壤之别。去年才如梦初醒一般，勉强会了一点点 VBA 查找和替换的方法，这还是和 杜先生、ming0018 老师 学的呢！数组只会一维的，并且不熟练，是向 loquat 老师 学的；还有，清除段首段尾空格的两行代码，是照搬 zhanglei1371 老师的代码；其中最多的是向 杜先生 学习的不少“VBA方法”。

相见是缘8

小花鹿 发表于 2019-5-27 17:00
我专门找了一个电脑，WINXP+OFFICE2003，试验结果绝对没问题，你们不出结果，我也不知道啥原因，郁闷

好的、让老师费心了，谢谢！

小花鹿

相见是缘8 发表于 2019-5-28 06:58
好的、让老师费心了，谢谢！

这样试试行不行：
Sub test()
    Dim mydoc As Document, ed&
    Set mydoc = Documents.Add
    With ThisDocument.Content.Find
        .ClearFormatting
        .Text = ""
        .Font.Color = wdColorGreen
        .Forward = True
        .MatchWildcards = True
        Do While .Execute
            ed = mydoc.Range.End
            mydoc.Range(ed - 1, ed - 1).FormattedText = .Parent.Paragraphs(1).Range.FormattedText
            .Parent.Move 4
        Loop
    End With
End Sub

相见是缘8

小花鹿 发表于 2019-5-28 13:24
这样试试行不行：
Sub test()
    Dim mydoc As Document, ed&

难为老师了，还是提取不了，光新建了一个文档，里面空白。

相见是缘8

413191246se 发表于 2019-5-28 00:48
* 向 小花鹿 老师 道歉！对不起！您的代码我和 相见 一样，没得到正确结果，我猜是我俩儿的水平有问题，不 ...

哈哈！老师你过歉了！杜老师是高手中的高手不假，我觉得你至少也是高手！

413191246se

小花鹿 老师：这个“ThisDocuments”和“ActiveDocument”不一样，我想它应该是放在要提取的文档中的，但放了后并且存了盘，再调入还是无效，不知道是怎么回事，我们一般是把代码放在 Normal.dot 中的。

zhanglei1371

这样肯定可行：
Sub test()
    Dim mydoc As Document, ed&
    Set mydoc = Documents.Add(Visible:=False)
    With ThisDocument.Content.Find
        .ClearFormatting
        .Text = ""
        .Font.Color = wdColorGreen
        .Forward = True
        .MatchWildcards = True
        Do While .Execute
            ed = mydoc.Range.End
            mydoc.Range(ed - 1, ed - 1).FormattedText = .Parent.Paragraphs(1).Range.FormattedText
            .Parent.Move 4
        Loop
    End With
    mydoc.Application.Visible = True '感谢凯文的提示
End Sub