如何使用VBA查找和删除PowerPoint中句子中的重复单词？

如何在PowerPoint中查找并删除句子中重复的单词

作为语法检查，我想找出打字错误的两个单词。例如：

Stackoverflow是一个大型站点

---

在本例中，将删除一个“a”

我的朋友，如果你试图重新发明自动语法检查，那么你正在着手一项危险的任务。自然语言中充满了例外情况，保证能规避任何你认为能起作用的小规则集

无论如何，下面是一个很明显的天真的尝试。现在，这段代码适用于您给出的示例。它将删除额外的“a”。但请注意，如果你想保留语法、语法和语义，就不应该删除所有重复的单词。自动删除重复的“that”将在以下方面产生奇迹：

我喜欢那个网站

但它将改变作者的意图，将语法降低到一个非常非正式的水平：

她说那是一个很棒的网站

删除重复将彻底毁掉这里的一切：

更不用说：

为灾难做好准备！但无论如何，该代码适用于您的示例（以及更多示例），并为您提供了一个框架，供您构建和微调，以使其适用于大多数与您相关的情况

Dim shp As Shape
Dim str As String
Dim wordArr() As String
Dim words As Collection
Dim iWord As Long
Dim thisWord As String
Dim nextWord As String
Dim newText As String

For Each shp In ActivePresentation.Slides(1).Shapes
    If shp.HasTextFrame Then
        'Get the text
        str = shp.TextFrame.TextRange.Text
        'Split it into an array of words
        wordArr = Split(str, " ")

        'Transfer to a Collection, easier to deal with than array.
        Set words = New Collection
        For iWord = LBound(wordArr) To UBound(wordArr)
            words.Add wordArr(iWord)
        Next iWord

        'Look for repeats.
        For iWord = words.Count - 1 To 1 Step -1
            thisWord = words.Item(iWord)
            nextWord = words.Item(iWord + 1)

            'Make sure commas don't get in the way of a comparison
            'e.g. "This is a great, great site" is fine
            'but "This site is great great, and I love it" is not.
            nextWord = Replace(nextWord, ",", "")
            'Add whatever other filtering you feel is appropriate.
            'e.g. period, case sensitivity, etc.

            If LCase(thisWord) = LCase(nextWord) Then
                If LCase(thisWord) = "that" Then
                    'Do nothing. "He said that that was great." is ok.
                    'This is just an example. "had" is another.
                    'Add more filtering here.
                Else
                    words.Remove iWord + 1
                End If
            End If
        Next iWord

        'Assemble the text with repeats removed.
        newText = ""
        For iWord = 1 To words.Count
            newText = newText & words.Item(iWord) & " "
        Next iWord

        'Finally, put it back on the slide.
        shp.TextFrame.TextRange.Text = newText
    End If
Next shp

---

正则表达式使这变得很好和简单

Function remove_duplicates()

    txt = "Stackoverflow is a a greate site"

    Set word_match = CreateObject("vbscript.regexp")
    word_match.IgnoreCase = True
    word_match.Global = True

    For Each wrd In Split(txt, " ")
        word_match.Pattern = wrd & " " & wrd
        txt = word_match.Replace(txt, wrd)
    Next

    MsgBox txt

End Function

---

这是一个经典的

RegExp

应用程序，可以使用反向引用一次性删除所有重复的单词（而不是逐字循环）

注意：如果您需要访问底层PPT文本的详细帮助，则需要提供更多有关文本在幻灯片中出现位置的信息

Sub TestString()
    MsgBox ReducedText("stackoverflow stackoverflow Stackoverflow is a a great site")
End Sub

Function ReducedText(strIn As String) As String
    Dim objRegex As Object
    Set objRegex = CreateObject("vbscript.regexp")
    With objRegex
        .IgnoreCase = True
        .Global = True
        .Pattern = "\b(\w+)\b(\s+\1\b)+"
        ReducedText = .Replace(strIn, "$1")
    End With
End Function

---

如果对每个形状进行优化，那么最好从所有项目中获取所有文本，并将它们放在一个称为段落的字符串中。删除任何逗号。将任何句点（“.”）拆分为另一个称为句子的数组。然后对每个句子中用空格隔开的相邻两个单词进行并排测试。你提出了一个很好的观点，即某些折叠单词可能是可以的，因此修改提示用户输入这些输入是有用的。虽然你的代码确实可以工作（我确实测试过），而且是逻辑设计的，但它比现成的解析工具走的路要长得多。@brettdj：我同意正则表达式会更简洁，但一旦你添加了所有必需的自然语言异常处理，它不会变得完全神秘和不可读吗？它肯定会变得更难。我认为Word和Outlook使用了与我在下面提出的类似的regexp来标记潜在问题。也许运行一个<>代码> ReXEP < /Cord>对用户可能以同样方式考虑的潜在问题是一个比直接改变更好的评价。我不是ReExp专家，但我很确定这不是一个特别好的使用方法…@Jean-FrançoisCorbett，这很有趣，因为上面你说过，我必须在某个时候学习RegExp。谢谢你对regex的意见-一个不认识regex的家伙！我们不是在挖苦人吗。。。使用正则表达式基本上是模拟本机VBA

Replace

函数的一种迂回方式：它完全等同于

txt=Replace（txt，wrd&&&&&wrd，wrd）

。所以，是的，我知道你使用regex并没有带来什么特别的好处，只是增加了复杂性。@Jean-FrançoisCorbett你明白了。@Jean-FrançoisCorbett对

RegExp

usage和共享学习的有效评论。